Test-Simple-1.302125/0000755000175000017500000000000013243466361014045 5ustar exodistexodistTest-Simple-1.302125/xt/0000755000175000017500000000000013243466361014500 5ustar exodistexodistTest-Simple-1.302125/xt/author/0000755000175000017500000000000013243466361016002 5ustar exodistexodistTest-Simple-1.302125/xt/author/pod-syntax.t0000644000175000017500000000025213243466361020274 0ustar exodistexodist#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Test-Simple-1.302125/xt/author/pod-spell.t0000644000175000017500000000243313243466361020070 0ustar exodistexodistuse strict; use warnings; BEGIN { eval { require Test::Spelling; } or do { print "1..0 # SKIP Don't have Test::Spelling\n"; exit 0; }; Test::Spelling->import; } my @stopwords; for () { chomp; push @stopwords, $_ unless /\A (?: \# | \s* \z)/msx; # skip comments, whitespace } print "### adding stopwords @stopwords\n"; add_stopwords(@stopwords); local $ENV{LC_ALL} = 'C'; set_spell_cmd('aspell list -l en'); all_pod_files_spelling_ok; __DATA__ ## personal names binkley Bowden Daly dfs Eryq EXODIST Fergal Glew Granum Oxley Pritikin Schwern Skoll Slaymaker ZeeGee ## proper names Fennec ICal xUnit ## test jargon Diag diag isnt subtest subtests testsuite testsuites TODO todo todos untestable EventFacet renderers ## computerese blackbox BUF codeblock combinatorics dir getline getlines getpos Getter getters HashBase heisenbug IPC NBYTES param perlish perl-qa POS predeclaring rebless refactoring refcount Reinitializes SCALARREF setpos Setter SHM sref subevent subevents testability TIEHANDLE tie-ing unoverload VMS vmsperl YESNO ansi html HASHBASE renderer ## other jargon, slang 17th AHHHHHHH Dummy globalest Hmmm cid tid pid SIGINT SIGALRM SIGHUP SIGTERM SIGUSR1 SIGUSR2 env ## Spelled correctly according to google: recognises Test-Simple-1.302125/examples/0000755000175000017500000000000013243466361015663 5ustar exodistexodistTest-Simple-1.302125/examples/indent.pl0000644000175000017500000000125113243466361017500 0ustar exodistexodist#!/usr/bin/env perl use strict; use warnings; use lib '../lib'; use Test::Builder; =head1 NOTES Must have explicit finalize Must name nest Trailing summary test Pass chunk o'TAP No builder may have more than one child active What happens if you call ->finalize with open children =cut my $builder = Test::Builder->new; $builder->plan(tests => 7); for( 1 .. 3 ) { $builder->ok( $_, "We're on $_" ); $builder->note("We ran $_"); } { my $indented = $builder->child; $indented->plan('no_plan'); for( 1 .. 1+int(rand(5)) ) { $indented->ok( 1, "We're on $_" ); } $indented->finalize; } for( 7, 8, 9 ) { $builder->ok( $_, "We're on $_" ); } Test-Simple-1.302125/examples/subtest.t0000644000175000017500000000053413243466361017543 0ustar exodistexodist#!/usr/bin/env perl use strict; use warnings; use lib '../lib'; use Test::More tests => 3; ok 1; subtest 'some name' => sub { my $num_tests = 2 + int( rand(3) ); plan tests => $num_tests; ok 1 for 1 .. $num_tests - 1; subtest 'some name' => sub { plan 'no_plan'; ok 1 for 1 .. 2 + int( rand(3) ); }; }; ok 1; Test-Simple-1.302125/examples/tools.pl0000644000175000017500000000577513243466361017376 0ustar exodistexodistpackage Test2::Example; use Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2 qw/context run_subtest/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool ? 1 : 0; } sub is($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" eq "$want"; } elsif (defined($got) xor defined($want)) { $bool = 0; } else { # Both are undef $bool = 1; } unless ($bool) { $got = '*NOT DEFINED*' unless defined $got; $want = '*NOT DEFINED*' unless defined $want; unshift @diag => ( "GOT: $got", "EXPECTED: $want", ); } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub isnt($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" ne "$want"; } elsif (defined($got) xor defined($want)) { $bool = 1; } else { # Both are undef $bool = 0; } unshift @diag => "Strings are the same (they should not be)" unless $bool; $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub like($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" =~ $pattern; unshift @diag => ( "Value: $thing", "Does not match: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub unlike($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" !~ $pattern; unshift @diag => ( "Unexpected pattern match (it should not match)", "Value: $thing", "Matches: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub diag { my $ctx = context(); $ctx->diag( join '', @_ ); $ctx->release; } sub note { my $ctx = context(); $ctx->note( join '', @_ ); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub subtest { my ($name, $code) = @_; my $ctx = context(); my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } 1; Test-Simple-1.302125/examples/tools.t0000644000175000017500000001107213243466361017211 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; use Test2::API qw/context intercept test2_stack/; ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{ ok is isnt like unlike diag note is_deeply warnings exception plan skip_all done_testing }; ok(1, "'ok' Test"); is("foo", "foo", "'is' test"); is(undef, undef, "'is' undef test"); isnt("foo", "bar", "'isnt' test"); isnt("foo", undef, "'isnt' undef test 1"); isnt(undef, "foo", "'isnt' undef test 2"); like("foo", qr/o/, "'like' test"); unlike("foo", qr/a/, "'unlike' test"); diag("Testing Diag"); note("Testing Note"); my $str = "abc"; is_deeply( { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}}, { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}}, "'is_deeply' test" ); is_deeply( warnings { warn "aaa\n"; warn "bbb\n" }, [ "aaa\n", "bbb\n" ], "Got warnings" ); is_deeply( warnings { 1 }, [], "no warnings" ); is(exception { die "foo\n" }, "foo\n", "got exception"); is(exception { 1 }, undef, "no exception"); my $events = intercept { plan 8; ok(0, "'ok' Test"); is("foo", "bar", "'is' test"); isnt("foo", "foo", "'isnt' test"); like("foo", qr/a/, "'like' test"); unlike("foo", qr/o/, "'unlike' test"); diag("Testing Diag"); note("Testing Note"); is_deeply( { a => 1, b => 2, c => {}}, { a => 1, b => 2, c => []}, "'is_deeply' test" ); }; is(@$events, 9, "got 9 events"); my ($plan, $ok, $is, $isnt, $like, $unlike, $diag, $note, $is_deeply) = @$events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); is($ok->pass, 0, "'ok' test failed"); ok($is->isa('Test2::Event::Ok'), "got 'is' result"); is($is->pass, 0, "'is' test failed"); ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result"); is($isnt->pass, 0, "'isnt' test failed"); ok($like->isa('Test2::Event::Ok'), "got 'like' result"); is($like->pass, 0, "'like' test failed"); ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result"); is($unlike->pass, 0, "'unlike' test failed"); ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result"); is($is_deeply->pass, 0, "'is_deeply' test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); ok($note->isa('Test2::Event::Note'), "got 'note' result"); is($note->message, "Testing Note", "got note message"); $events = intercept { skip_all 'because'; ok(0, "should not see me"); die "should not happen"; }; is(@$events, 1, "1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); is($events->[0]->directive, 'SKIP', "plan is skip"); is($events->[0]->reason, 'because', "skip reason"); $events = intercept { is(undef, ""); is("", undef); isnt(undef, undef); like(undef, qr//); unlike(undef, qr//); }; is(@$events, 5, "5 events"); ok(!$_->pass, "undef test - should not pass") for @$events; sub tool { context() }; my %params; my $ctx = context(level => -1); my $ictx; $events = intercept { %params = @_; $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); my $trace = Test2::Context::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); }; is_deeply( \%params, { context => $ctx, hub => $ictx->hub, }, "Passed in some useful params" ); ok($ctx != $ictx, "Different context inside intercept"); is(@$events, 3, "got 3 events"); $ctx->release; $ictx->release; # Test that a bail-out in an intercept does not exit. $events = intercept { $ictx = tool(); $ictx->bail("The world ends"); $ictx->ok(0, "Should not see this"); }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); $events = intercept { $ictx = tool(); }; $ictx->release; like( exception { intercept { die 'foo' } }, qr/foo/, "Exception was propogated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; Test-Simple-1.302125/t/0000755000175000017500000000000013243466361014310 5ustar exodistexodistTest-Simple-1.302125/t/Legacy_And_Test2/0000755000175000017500000000000013243466361017357 5ustar exodistexodistTest-Simple-1.302125/t/Legacy_And_Test2/builder_loaded_late.t0000644000175000017500000000107413243466361023511 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-PRELOAD use Test2::Tools::Tiny; use Test2::API qw/intercept test2_stack/; plan 3; my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; require Test::Builder; }; is(@warnings, 2, "got warnings"); like( $warnings[0], qr/Test::Builder was loaded after Test2 initialization, this is not recommended/, "Warn about late Test::Builder load" ); like( $warnings[1], qr/Formatter Test::Builder::Formatter loaded too late to be used as the global formatter/, "Got the formatter warning" ); Test-Simple-1.302125/t/Legacy_And_Test2/preload_diag_note.t0000644000175000017500000000123413243466361023203 0ustar exodistexodistuse strict; use warnings; if ($] lt "5.008") { print "1..0 # SKIP Test cannot run on perls below 5.8.0\n"; exit 0; } BEGIN { require Test2::API; Test2::API::test2_start_preload(); } use Test::More; my ($stdout, $stderr) = ('', ''); { local *STDOUT; open(STDOUT, '>', \$stdout) or die "Could not open temp STDOUT"; local *STDERR; open(STDERR, '>', \$stderr) or die "Could not open temp STDOUT"; diag("test\n", "diag\nfoo"); note("test\n", "note\nbar"); } Test2::API::test2_stop_preload(); is($stdout, <isa('Test2::Event::Ok'), "got 'ok' result"); is($ok->pass, 0, "'ok' test failed"); is($ok->name, 'name', "got 'ok' name"); ok($diag->isa('Test2::Event::Diag'), "got 'ok' result"); is($diag->message, " Failed test 'name'\n at $0 line 9.\n", "got all diag message in one diag event"); done_testing; Test-Simple-1.302125/t/Legacy_And_Test2/hidden_warnings.t0000644000175000017500000000046313243466361022712 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw( context_do ); $SIG{__WARN__} = sub { context_do { shift->throw("oops\n"); } $_[0]; }; my $array_var = []; eval { warn "trigger warning" }; my $err = $@; like( $err, qr/oops/, "Got expected error" ); done_testing(); Test-Simple-1.302125/t/regression/0000755000175000017500000000000013243466361016470 5ustar exodistexodistTest-Simple-1.302125/t/regression/buffered_subtest_plan_buffered.t0000644000175000017500000000116013243466361025062 0ustar exodistexodistuse Test2::Tools::Tiny; use strict; use warnings; use Test2::API qw/intercept test2_stack/; use Data::Dumper; sub hide_buffered { 0 } sub write { my $self = shift; my ($e) = @_; push @{$self->{events}} => $e; } sub finalize { } my $events; intercept { my $hub = test2_stack()->top; my $formatter = bless({}, __PACKAGE__); $hub->format($formatter); tests xxx => sub { ok(1, "pass"); }; $events = $formatter->{events}; }; pop @$events; for my $e (@$events) { ok($e->trace->buffered, "Buffered events are all listed as buffered") || diag(Dumper($e)); } done_testing; Test-Simple-1.302125/t/regression/694_note_diag_return_values.t0000644000175000017500000000062113243466361024165 0ustar exodistexodistuse Test::More; use strict; use warnings; use Test2::API qw/intercept/; my @returns; intercept { push @returns => diag('foo'); push @returns => note('foo'); my $tb = Test::Builder->new; push @returns => $tb->diag('foo'); push @returns => $tb->note('foo'); }; is(@returns, 4, "4 return values"); is_deeply(\@returns, [0, 0, 0, 0], "All note/diag returns are 0"); done_testing; Test-Simple-1.302125/t/regression/721-nested-streamed-subtest.t0000644000175000017500000000561413243466361023745 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; # This module's exports interfere with the ones in t/tools.pl use Test::More (); use Test::Builder::Formatter(); use Test2::API qw/run_subtest test2_stack/; { test2_stack->top; my $temp_hub = test2_stack->new_hub(); $temp_hub->format(Test::Builder::Formatter->new()); my $output = capture { run_subtest( 'parent', sub { run_subtest( 'buffered', sub { ok(1, 'b1'); ok(1, 'b2'); }, {buffered => 1}, ); run_subtest( 'streamed', sub { ok(1, 's1'); ok(1, 's2'); }, {buffered => 0}, ); }, {buffered => 1}, ); }; test2_stack->pop($temp_hub); Test::More::subtest( 'Test2::API::run_subtest', sub { is($output->{STDERR}, q{}, 'no output on stderr'); like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); } ); } { test2_stack->top; my $temp_hub = test2_stack->new_hub(); $temp_hub->format(Test::Builder::Formatter->new()); my $output = capture { run_subtest( 'parent', sub { run_subtest( 'buffered', sub { ok(1, 'b1'); ok(1, 'b2'); }, {buffered => 1}, ); Test::More::subtest( 'streamed', sub { ok(1, 's1'); ok(1, 's2'); }, {buffered => 0}, ); }, {buffered => 1}, ); }; test2_stack->pop($temp_hub); Test::More::subtest( 'Test::More::subtest and Test2::API::run_subtest', sub { is($output->{STDERR}, q{}, 'no output on stderr'); like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); } ); } done_testing; Test-Simple-1.302125/t/regression/696-intercept_skip_all.t0000644000175000017500000000175513243466361023062 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept/; tests in_eval => sub { my $events = intercept { eval { skip_all "foo" }; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; tests no_eval => sub { my $events = intercept { skip_all "foo"; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; tests in_require => sub { my $events = intercept { require './t/lib/SkipAll.pm'; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; done_testing; Test-Simple-1.302125/t/regression/builder_does_not_init.t0000644000175000017500000000055213243466361023222 0ustar exodistexodistuse strict; use warnings; use Carp qw/confess/; use Test2::API::Instance; BEGIN { no warnings 'redefine'; local *Test2::API::Instance::_finalize = sub { confess "_finalize called\n" }; local *Test2::API::Instance::load = sub { confess "load called\n" }; require Test::Builder; } use Test2::Tools::Tiny; ok(1, "Did not die"); done_testing(); Test-Simple-1.302125/t/regression/684-nested_todo_diag.t0000644000175000017500000000101013243466361022457 0ustar exodistexodistuse Test::More; use strict; use warnings; use Test2::API qw/intercept/; my @events; intercept { local $TODO = "broken"; Test2::API::test2_stack->top->listen(sub { push @events => $_[1] }, inherit => 1); subtest foo => sub { subtest bar => sub { ok(0, 'oops'); }; }; }; my ($event) = grep { $_->trace->line == 16 && ref($_) eq 'Test::Builder::TodoDiag'} @events; ok($event, "nested todo diag on line 16 was changed to TodoDiag (STDOUT instead of STDERR)"); done_testing; Test-Simple-1.302125/t/regression/757-reset_in_subtest.t0000644000175000017500000000044113243466361022555 0ustar exodistexodistuse strict; use warnings; use Test::More; subtest 'subtest' => sub { Test::Builder->new->reset; ok 1; }; subtest 'subtest' => sub { Test::Builder->new->reset; subtest 'subtest' => sub { Test::Builder->new->reset; ok 1; }; ok 1; }; done_testing; Test-Simple-1.302125/t/regression/642_persistent_end.t0000644000175000017500000000067513243466361022306 0ustar exodistexodistuse Test::More; use strict; use warnings; use Test2::API qw{ test2_set_is_end test2_get_is_end intercept }; my %res; intercept { my $tb = Test::Builder->new; $res{before} = test2_get_is_end(); test2_set_is_end(); $res{isset} = test2_get_is_end(); $tb->reset; $res{reset} = test2_get_is_end(); }; ok(!$res{before}, "Not the end"); ok($res{isset}, "the end"); ok(!$res{reset}, "Not the end"); done_testing; Test-Simple-1.302125/t/regression/no_name_in_subtest.t0000644000175000017500000000020713243466361022527 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; ok(1, ""); tests foo => sub { ok(1, "name"); ok(1, ""); }; done_testing; Test-Simple-1.302125/t/regression/662-tbt-no-plan.t0000644000175000017500000000106413243466361021324 0ustar exodistexodistuse Test::Builder::Tester; use Test::More tests => 1; use strict; use warnings; BEGIN { package Example::Tester; use base 'Test::Builder::Module'; $INC{'Example/Tester.pm'} = 1; sub import { my $package = shift; my %args = @_; my $callerpack = caller; my $tb = __PACKAGE__->builder; $tb->exported_to($callerpack); local $SIG{__WARN__} = sub { }; $tb->no_plan; } } test_out('ok 1 - use Example::Tester;'); use_ok('Example::Tester'); test_test("use Example::Tester;"); Test-Simple-1.302125/t/regression/todo_and_facets.t0000644000175000017500000000161213243466361021771 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; use Test2::Tools::Tiny qw/done_testing todo/; use Test::More(); BEGIN { *tm_ok = \&Test::More::ok; *tm_pass = \&Test::More::pass; *tm_fail = \&Test::More::fail; } use vars qw/$TODO/; sub leg_ok($;$@) { my ($bool, $name, @diag); my $ctx = context(); $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub new_ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } { local $TODO = "Testing TODO"; tm_ok(0, "tm_ok fail"); tm_fail('tm_fail'); leg_ok(0, "legacy ok fail"); new_ok(0, "new ok fail"); } todo new_todo_test => sub { tm_ok(0, "tm_ok fail"); tm_fail('tm_fail'); leg_ok(0, "legacy ok fail"); new_ok(0, "new ok fail"); }; done_testing; Test-Simple-1.302125/t/regression/inherit_trace.t0000644000175000017500000000104413243466361021474 0ustar exodistexodistuse Test2::Tools::Tiny; use strict; use warnings; use Test2::API qw/context run_subtest intercept/; sub do_it { my $ctx = context(); run_subtest foo => sub { ok(1, "pass"); }, {inherit_trace => 1}; $ctx->release; } do_it(); do_it(); my $events = intercept { do_it(); do_it(); }; for my $st (@$events) { next unless $st->isa('Test2::Event::Subtest'); is($st->trace->nested, 0, "base subtest is not nested"); is($_->trace->nested, 1, "subevent is nested") for @{$st->subevents}; } done_testing; Test-Simple-1.302125/t/regression/errors_facet.t0000644000175000017500000000173113243466361021335 0ustar exodistexodistuse Test2::Tools::Tiny; use Test2::API qw/intercept context/; { $INC{'My/Event.pm'} = 1; package My::Event; use base 'Test2::Event'; use Test2::Util::Facets2Legacy ':ALL'; sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{errors} = [{tag => 'OOPS', fail => !$ENV{FAILURE_DO_PASS}, details => "An error occured"}]; return $out; } } sub error { my $ctx = context(); my $e = $ctx->send_event('+My::Event'); $ctx->release; return $e; } my $events = intercept { tests foo => sub { ok(1, "need at least 1 assertion"); error(); }; }; ok(!$events->[0]->pass, "Subtest did not pass"); my ($passing_a, $passing_b); intercept { my $hub = Test2::API::test2_stack->top; $passing_a = $hub->is_passing; error(); $passing_b = $hub->is_passing; }; ok($passing_a, "Passign before error"); ok(!$passing_b, "Not passing after error"); done_testing; Test-Simple-1.302125/t/Test2/0000755000175000017500000000000013243466361015311 5ustar exodistexodistTest-Simple-1.302125/t/Test2/acceptance/0000755000175000017500000000000013243466361017377 5ustar exodistexodistTest-Simple-1.302125/t/Test2/acceptance/try_it_done_testing.t0000644000175000017500000000060013243466361023634 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; sub done_testing { my $ctx = context(); die "Test Already ended!" if $ctx->hub->ended; $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } ok(1, "First"); ok(1, "Second"); done_testing; 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_no_plan.t0000644000175000017500000000046513243466361022611 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, 'no_plan'); ok(1, "First"); ok(1, "Second"); 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_threads.t0000644000175000017500000000110313243466361022603 0ustar exodistexodistuse strict; use warnings; use Test2::Util qw/CAN_THREAD/; use Test2::IPC; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, skip_all => 'System does not have threads') unless CAN_THREAD(); plan(6); require threads; threads->import; for (1 .. 3) { threads->create(sub { ok(1, "test 1 in thread " . threads->tid()); ok(1, "test 2 in thread " . threads->tid()); }); } 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_skip.t0000644000175000017500000000031713243466361022125 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } plan(0, skip_all => 'testing skip all'); die "Should not see this"; 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_fork.t0000644000175000017500000000104213243466361022114 0ustar exodistexodistuse strict; use warnings; use Test2::Util qw/CAN_FORK/; use Test2::IPC; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, skip_all => 'System cannot fork') unless CAN_FORK(); plan(6); for (1 .. 3) { my $pid = fork; die "Failed to fork" unless defined $pid; next if $pid; ok(1, "test 1 in pid $$"); ok(1, "test 2 in pid $$"); last; } 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_plan.t0000644000175000017500000000045213243466361022111 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(2); ok(1, "First"); ok(1, "Second"); 1; Test-Simple-1.302125/t/Test2/acceptance/try_it_todo.t0000644000175000017500000000164313243466361022127 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context test2_stack/; sub done_testing { my $ctx = context(); die "Test Already ended!" if $ctx->hub->ended; $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } sub diag { my $ctx = context(); $ctx->diag( join '', @_ ); $ctx->release; } ok(1, "First"); my $filter = test2_stack->top->filter(sub { my ($hub, $event) = @_; # Turn a diag into a note return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; # Set todo on ok's if ($event->isa('Test2::Event::Ok')) { $event->set_todo('here be dragons'); $event->set_effective_pass(1); } return $event; }); ok(0, "Second"); diag "should be a note"; test2_stack->top->unfilter($filter); ok(1, "Third"); done_testing; Test-Simple-1.302125/t/Test2/regression/0000755000175000017500000000000013243466361017471 5ustar exodistexodistTest-Simple-1.302125/t/Test2/regression/ipc_files_abort_exit.t0000644000175000017500000000363213243466361024037 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Util qw/CAN_FORK/; BEGIN { skip_all "Set AUTHOR_TESTING to run this test" unless $ENV{AUTHOR_TESTING}; skip_all "System cannot fork" unless CAN_FORK; skip_all "known to fail on $]" if $] le "5.006002"; } use IPC::Open3 qw/open3/; use File::Temp qw/tempdir/; my $tempdir = tempdir(CLEANUP => 1); open(my $stdout, '>', "$tempdir/stdout") or die "Could not open: $!"; open(my $stderr, '>', "$tempdir/stderr") or die "Could not open: $!"; my $pid = open3(undef, ">&" . fileno($stdout), ">&" . fileno($stderr), $^X, '-Ilib', '-e', <<'EOT'); use Test2::IPC::Driver::Files; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/test2_ipc/; plan 1; ok(1); my $tmpdir = test2_ipc()->tempdir; open(my $fh, '>', "$tmpdir/leftover") or die "Could not open file: $!"; print $fh "XXX\n"; close($fh) or die "Could not clone file"; print "TEMPDIR: $tmpdir\n"; exit 100; EOT waitpid($pid, 0); my $exit = $?; open($stdout, '<', "$tempdir/stdout") or die "Could not open: $!"; open($stderr, '<', "$tempdir/stderr") or die "Could not open: $!"; $stdout = join "" => <$stdout>; $stderr = join "" => <$stderr>; is(($exit >> 8), 255, "exited 255"); like($stderr, qr{^IPC Fatal Error: Leftover files in the directory \(.*/leftover\)!$}m, "Got expected error"); like($stdout, qr{^Bail out! IPC Fatal Error: Leftover files in the directory \(.*leftover\)!$}m, "Got a bail printed"); if(ok($stdout =~ m/^TEMPDIR: (.*)$/m, "Found temp dir")) { chomp(my $tmpdir = $1); if (-d $tmpdir) { note "Cleaning up temp dir\n"; opendir(my $dh, $tmpdir) or diag "Could not open temp dir: $!"; for my $file (readdir($dh)) { next if $file =~ m/^\./; unlink("$tmpdir/$file") or diag "Could not remove $tmpdir/$file: $!"; } closedir($dh); rmdir($tmpdir) or diag "Could not remove temp dir: $!"; } } done_testing; Test-Simple-1.302125/t/Test2/regression/746-forking-subtest.t0000644000175000017500000000205013243466361023317 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context intercept test2_stack/; use Test2::Util qw/CAN_FORK/; BEGIN { skip_all "System cannot fork" unless CAN_FORK; } my $events = intercept { Test2::API::run_subtest("this subtest forks" => sub { if (fork) { wait; isnt($?, 0, "subprocess died"); } else { # Prevent the exception from being rendered to STDERR, people have # complained about STDERR noise in tests before. close STDERR; die "# Expected warning from subtest"; }; }, {no_fork => 1}); }; my @subtests = grep {; $_->isa('Test2::Event::Subtest') } @$events; if (is(@subtests, 1, "only one subtest run, effectively")) { my @subokay = grep {; $_->facets->{assert} } @{ $subtests[0]->subevents }; is(@subokay, 1, "we got one test result inside the subtest"); ok(! $subokay[0]->causes_fail, "...and it passed"); } else { # give up, we're already clearly broken } done_testing; Test-Simple-1.302125/t/Test2/regression/693_ipc_ordering.t0000644000175000017500000000114213243466361022721 0ustar exodistexodistuse Test2::Tools::Tiny; use strict; use warnings; skip_all("Test cannot run on perls below 5.8.8") unless "$]" > 5.008007; use Test2::Util qw/CAN_THREAD/; use Test2::IPC; use Test2::API qw/context intercept/; skip_all('System does not have threads') unless CAN_THREAD(); require threads; threads->import; my $events = intercept { threads->create( sub { ok 1, "something $_ nonlocal" for (1 .. 15); } )->join; }; is_deeply( [map { $_->{name} } @$events], [map "something $_ nonlocal", 1 .. 15], "Culled sub-thread events in correct order" ); done_testing; Test-Simple-1.302125/t/Test2/regression/gh_16.t0000644000175000017500000000172313243466361020565 0ustar exodistexodistuse strict; use warnings; # This test checks for a pretty rare condition, one that was mainly a problem # on 5.20+ (though a 5.8 also had the problem). I am not too worried about this # breaking again. That said I still want it run on newer perls (where it is # less likely to fail for an unrelated reason) and when I have AUTHOR_TESTING # set. BEGIN { unless($ENV{AUTHOR_TESTING} || eval "no warnings 'portable'; require 5.20; 1") { print "1..0 # Skip Crazy test, only run on 5.20+, or when AUTHOR_TESTING is set\n"; exit 0; } } # This test is for gh #16 # Also see https://rt.perl.org/Public/Bug/Display.html?id=127774 # Ceate this END before anything else so that $? gets set to 0 END { $? = 0 } BEGIN { print "\n1..1\n"; close(STDERR); open(STDERR, '>&STDOUT'); } use Test2::API; eval(' sub { die "xxx" } ')->(); END { sub { my $ctx = Test2::API::context(); $ctx->release; }->(); print "ok 1 - Did not segv\n"; $? = 0; } Test-Simple-1.302125/t/Test2/behavior/0000755000175000017500000000000013243466361017110 5ustar exodistexodistTest-Simple-1.302125/t/Test2/behavior/Subtest_buffer_formatter.t0000644000175000017500000000517013243466361024345 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept test2_stack/; { package Formatter::Hide; sub write { } sub hide_buffered { 1 } sub terminate { } sub finalize { } package Formatter::Show; sub write { } sub hide_buffered { 0 } sub terminate { } sub finalize { } package Formatter::NA; sub write { } sub terminate { } sub finalize { } } my %HAS_FORMATTER; my $events = intercept { my $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_none} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_none} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### test2_stack->top->format(bless {}, 'Formatter::Hide'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_hide} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_hide} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### test2_stack->top->format(bless {}, 'Formatter::Show'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_show} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_show} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_na} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); test2_stack->top->format(bless {}, 'Formatter::NA'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_na} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); }; ok(!$HAS_FORMATTER{unbuffered_none}, "Unbuffered with no parent formatter has no formatter"); ok( $HAS_FORMATTER{unbuffered_show}, "Unbuffered where parent has 'show' formatter has formatter"); ok( $HAS_FORMATTER{unbuffered_hide}, "Unbuffered where parent has 'hide' formatter has formatter"); ok(!$HAS_FORMATTER{buffered_none}, "Buffered with no parent formatter has no formatter"); ok( $HAS_FORMATTER{buffered_show}, "Buffered where parent has 'show' formatter has formatter"); ok(!$HAS_FORMATTER{buffered_hide}, "Buffered where parent has 'hide' formatter has no formatter"); done_testing; Test-Simple-1.302125/t/Test2/behavior/nested_context_exception.t0000644000175000017500000000413313243466361024402 0ustar exodistexodistuse strict; use warnings; BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } use Test2::Tools::Tiny; use Test2::API qw/context/; skip_all("known to fail on $]") if $] le "5.006002"; sub outer { my $code = shift; my $ctx = context(); $ctx->note("outer"); my $out = eval { $code->() }; $ctx->release; return $out; } sub dies { my $ctx = context(); $ctx->note("dies"); die "Foo"; } sub bad_store { my $ctx = context(); $ctx->note("bad store"); return $ctx; # Emulate storing it somewhere } sub bad_simple { my $ctx = context(); $ctx->note("bad simple"); return; } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; eval { dies() }; } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); my $keep = bad_store(); eval { my $x = 1 }; # Ensure an eval changing $@ does not meddle. { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(@warnings, "got warnings"); like( $warnings[0], qr/context\(\) was called to retrieve an existing context/, "got expected warning" ); $keep = undef; { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; bad_simple(); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); @warnings = (); outer(\&dies); { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); { local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_store); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_simple); } ok(@warnings, "got warnings") || diag @warnings; like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); done_testing; Test-Simple-1.302125/t/Test2/behavior/run_subtest_inherit.t0000644000175000017500000000433013243466361023374 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept context/; # Test a subtest that should inherit the trace from the tool that calls it my ($file, $line) = (__FILE__, __LINE__ + 1); my $events = intercept { my_tool_inherit() }; is(@$events, 1, "got 1 event"); my $e = shift @$events; ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); is($e->trace->file, $file, "subtest is at correct file"); is($e->trace->line, $line, "subtest is at correct line"); my $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { is($se->trace->file, $file, "subtest event is at correct file"); is($se->trace->line, $line, "subtest event is at correct line"); ok($se->facets->{assert}->pass, "subtest event passed"); } # Test a subtest that should NOT inherit the trace from the tool that calls it ($file, $line) = (__FILE__, __LINE__ + 1); $events = intercept { my_tool_no_inherit() }; is(@$events, 1, "got 1 event"); $e = shift @$events; ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); is($e->trace->file, $file, "subtest is at correct file"); is($e->trace->line, $line, "subtest is at correct line"); $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { ok($se->trace->file ne $file, "subtest event is not in our file"); ok($se->trace->line ne $line, "subtest event is not on our line"); ok($se->facets->{assert}->{pass}, "subtest event passed"); } done_testing; # Make these tools appear to be in a different file/line #line 100 'fake.pm' sub my_tool_inherit { my $ctx = context(); run_subtest( 'foo', sub { ok(1, 'a'); ok(2, 'b'); is_deeply(\@_, [qw/arg1 arg2/], "got args"); }, {buffered => 1, inherit_trace => 1}, 'arg1', 'arg2' ); $ctx->release; } sub my_tool_no_inherit { my $ctx = context(); run_subtest( 'foo', sub { ok(1, 'a'); ok(2, 'b'); is_deeply(\@_, [qw/arg1 arg2/], "got args"); }, {buffered => 1, inherit_trace => 0}, 'arg1', 'arg2' ); $ctx->release; } Test-Simple-1.302125/t/Test2/behavior/ipc_wait_timeout.t0000644000175000017500000000445713243466361022654 0ustar exodistexodistuse strict; use warnings; # The things done in this test can trigger a buggy return value on some # platforms. This prevents that. The harness should catch actual failures. If # no harness is active then we will NOT sanitize the exit value, false fails # are better than false passes. END { $? = 0 if $ENV{HARNESS_ACTIVE} } # Some platforms throw a sigpipe in this test, we can ignore it. BEGIN { $SIG{PIPE} = 'IGNORE' } BEGIN { local ($@, $?, $!); eval { require threads } } use Test2::Tools::Tiny; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK/; use Test2::IPC; use Test2::API qw/test2_ipc_set_timeout test2_ipc_get_timeout/; my $plan = 2; $plan += 2 if CAN_REALLY_FORK; $plan += 2 if CAN_THREAD && threads->can('is_joinable'); plan $plan; is(test2_ipc_get_timeout(), 30, "got default timeout"); test2_ipc_set_timeout(10); is(test2_ipc_get_timeout(), 10, "hanged the timeout"); if (CAN_REALLY_FORK) { note "Testing process waiting"; my ($ppiper, $ppipew); pipe($ppiper, $ppipew) or die "Could not create pipe for fork"; my $proc = fork(); die "Could not fork!" unless defined $proc; unless ($proc) { local $SIG{ALRM} = sub { die "PROCESS TIMEOUT" }; alarm 15; my $ignore = <$ppiper>; exit 0; } my $exit; my $warnings = warnings { $exit = Test2::API::Instance::_ipc_wait(1); }; is($exit, 255, "Exited 255"); like($warnings->[0], qr/Timeout waiting on child processes/, "Warned about timeout"); print $ppipew "end\n"; close($ppiper); close($ppipew); } if (CAN_THREAD) { note "Testing thread waiting"; my ($tpiper, $tpipew); pipe($tpiper, $tpipew) or die "Could not create pipe for threads"; my $thread = threads->create( sub { local $SIG{ALRM} = sub { die "THREAD TIMEOUT" }; alarm 15; my $ignore = <$tpiper>; } ); if ($thread->can('is_joinable')) { my $exit; my $warnings = warnings { $exit = Test2::API::Instance::_ipc_wait(1); }; is($exit, 255, "Exited 255"); like($warnings->[0], qr/Timeout waiting on child thread/, "Warned about timeout"); } else { note "threads.pm is too old for a thread joining timeout :-("; } print $tpipew "end\n"; close($tpiper); close($tpipew); } Test-Simple-1.302125/t/Test2/behavior/Subtest_callback.t0000644000175000017500000000161213243466361022542 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $step = 0; my @callback_calls = (); Test2::API::test2_add_callback_pre_subtest( sub { is( $step, 0, 'pre-subtest callbacks should be invoked before the subtest', ); ++$step; push @callback_calls, [@_]; }, ); run_subtest( (my $subtest_name='some subtest'), (my $subtest_code=sub { is( $step, 1, 'subtest should be run after the pre-subtest callbacks', ); ++$step; }), undef, (my @subtest_args = (1,2,3)), ); is_deeply( \@callback_calls, [[$subtest_name,$subtest_code,@subtest_args]], 'pre-subtest callbacks should be invoked with the expected arguments', ); is( $step, 2, 'the subtest should be run', ); done_testing; Test-Simple-1.302125/t/Test2/behavior/trace_signature.t0000644000175000017500000000267013243466361022461 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use Test2::Util qw/get_tid/; my $line; my $events = intercept { $line = __LINE__ + 1; ok(1, "pass"); sub { my $ctx = context; $ctx->pass; $ctx->pass; $ctx->release; }->(); }; my $sigpass = $events->[0]->trace->signature; my $sigfail = $events->[1]->trace->signature; ok($sigpass ne $sigfail, "Each tool got a new signature"); is($events->[$_]->trace->signature, $sigfail, "Diags share failed ok's signature") for 2 .. $#$events; like($sigpass, qr/^C\d+:$$:\Q${ \get_tid() }:${ \__FILE__ }:$line\E$/, "signature is sane"); my $trace = Test2::EventFacet::Trace->new(frame => ['main', 'foo.t', 42, 'xxx']); is($trace->signature, undef, "No signature without a cid"); is($events->[0]->related($events->[1]), 0, "event 0 is not related to event 1"); is($events->[1]->related($events->[2]), 1, "event 1 is related to event 2"); my $e = Test2::Event::Ok->new(pass => 1); is($e->related($events->[0]), undef, "Cannot check relation, invalid trace"); $e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => ['', '', '', ''])); is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); $e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => [])); is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); done_testing; Test-Simple-1.302125/t/Test2/behavior/subtest_bailout.t0000644000175000017500000000223613243466361022510 0ustar exodistexodistuse Test2::Tools::Tiny; use strict; use warnings; use Test2::API qw/context run_subtest intercept/; sub subtest { my ($name, $code) = @_; my $ctx = context(); my $pass = run_subtest($name, $code, {buffered => 1}, @_); $ctx->release; return $pass; } sub bail { my $ctx = context(); $ctx->bail(@_); $ctx->release; } my $events = intercept { subtest outer => sub { subtest inner => sub { bail("bye!"); }; }; }; ok($events->[0]->isa('Test2::Event::Subtest'), "Got a subtest event when bail-out issued in a buffered subtest"); ok($events->[-1]->isa('Test2::Event::Bail'), "Bail-Out propogated"); ok(!$events->[-1]->facet_data->{trace}->{buffered}, "Final Bail-Out is not buffered"); ok($events->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside outer subtest"); ok($events->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); ok($events->[0]->subevents->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside inner subtest"); ok($events->[0]->subevents->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); done_testing; Test-Simple-1.302125/t/Test2/behavior/Subtest_events.t0000644000175000017500000000067113243466361022316 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $events = intercept { my $code = sub { ok(1) }; run_subtest('blah', $code, 'buffered'); }; ok(!$events->[0]->trace->nested, "main event is not inside a subtest"); ok($events->[0]->subtest_id, "Got subtest id"); is($events->[0]->subevents->[0]->trace->hid, $events->[0]->subtest_id, "nested events are in the subtest"); done_testing; Test-Simple-1.302125/t/Test2/behavior/disable_ipc_c.t0000644000175000017500000000040013243466361022027 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/test2_ipc_disable/; BEGIN { test2_ipc_disable() } use Test2::IPC::Driver::Files; ok(Test2::API::test2_ipc_disabled, "disabled IPC"); ok(!Test2::API::test2_ipc, "No IPC"); done_testing; Test-Simple-1.302125/t/Test2/behavior/disable_ipc_a.t0000644000175000017500000000031313243466361022030 0ustar exodistexodistuse strict; use warnings; no Test2::IPC; use Test2::Tools::Tiny; use Test2::IPC::Driver::Files; ok(Test2::API::test2_ipc_disabled, "disabled IPC"); ok(!Test2::API::test2_ipc, "No IPC"); done_testing; Test-Simple-1.302125/t/Test2/behavior/disable_ipc_d.t0000644000175000017500000000071213243466361022036 0ustar exodistexodistuse strict; use warnings; use Test2::Util qw/CAN_THREAD/; use Test2::API qw/context/; BEGIN { sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } unless (CAN_THREAD()) { plan(0, skip_all => 'System does not have threads'); exit 0; } } use threads; no Test2::IPC; use Test::More; ok(Test2::API::test2_ipc_disabled, "disabled IPC"); ok(!Test2::API::test2_ipc, "No IPC"); done_testing; Test-Simple-1.302125/t/Test2/behavior/special_names.t0000644000175000017500000000244213243466361022102 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-FORMATTER use Test2::Tools::Tiny; ######################### # # This test us here to insure that Ok renders the way we want # ######################### use Test2::API qw/test2_stack/; # Ensure the top hub is generated test2_stack->top; my $temp_hub = test2_stack->new_hub(); require Test2::Formatter::TAP; $temp_hub->format(Test2::Formatter::TAP->new); my $ok = capture { ok(1); ok(1, ""); ok(1, " "); ok(1, "A"); ok(1, "\n"); ok(1, "\nB"); ok(1, "C\n"); ok(1, "\nD\n"); ok(1, "E\n\n"); }; my $not_ok = capture { ok(0); ok(0, ""); ok(0, " "); ok(0, "A"); ok(0, "\n"); ok(0, "\nB"); ok(0, "C\n"); ok(0, "\nD\n"); ok(0, "E\n\n"); }; test2_stack->pop($temp_hub); is($ok->{STDERR}, "", "STDERR for ok is empty"); is($ok->{STDOUT}, <{STDOUT}, <[1], 'Test2::Event::Subtest', 'subtest ran'); ok($events->[1]->effective_pass, 'Test2::Event::Subtest', 'subtest effective_pass is true'); ok($events->[1]->todo, 'testing todo', 'subtest todo is set to expected value'); my $subevents = $events->[1]->subevents; is(scalar @$subevents, 3, 'got subevents in the subtest'); ok($subevents->[0]->facets->{assert}->pass, 'first event passed'); ok(!$subevents->[1]->facets->{assert}->pass, 'second event failed'); ok(!$subevents->[1]->causes_fail, 'second event does not cause failure'); done_testing; Test-Simple-1.302125/t/Test2/behavior/Subtest_plan.t0000644000175000017500000000054313243466361021742 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $events = intercept { my $code = sub { plan 4; ok(1) }; run_subtest('bad_plan', $code, 'buffered'); }; is( $events->[-1]->message, "Bad subtest plan, expected 4 but ran 1", "Helpful message if subtest has a bad plan", ); done_testing; Test-Simple-1.302125/t/Test2/behavior/no_load_api.t0000644000175000017500000000303113243466361021536 0ustar exodistexodistuse strict; use warnings; use Data::Dumper; # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD ############################################################################### # # # This test is to insure certain objects do not load Test2::API directly or # # indirectly when being required. It is ok for import() to load Test2::API if # # necessary, but simply requiring the modules should not. # # # ############################################################################### require Test2::Formatter; require Test2::Formatter::TAP; require Test2::Event; require Test2::Event::Bail; require Test2::Event::Diag; require Test2::Event::Exception; require Test2::Event::Note; require Test2::Event::Ok; require Test2::Event::Plan; require Test2::Event::Skip; require Test2::Event::Subtest; require Test2::Event::Waiting; require Test2::Util; require Test2::Util::ExternalMeta; require Test2::Util::HashBase; require Test2::EventFacet::Trace; require Test2::Hub; require Test2::Hub::Interceptor; require Test2::Hub::Subtest; require Test2::Hub::Interceptor::Terminator; my @loaded = grep { $INC{$_} } qw{ Test2/API.pm Test2/API/Instance.pm Test2/API/Context.pm Test2/API/Stack.pm }; require Test2::Tools::Tiny; Test2::Tools::Tiny::ok(!@loaded, "Test2::API was not loaded") || Test2::Tools::Tiny::diag("Loaded: " . Dumper(\@loaded)); Test2::Tools::Tiny::done_testing(); Test-Simple-1.302125/t/Test2/behavior/init_croak.t0000644000175000017500000000111513243466361021415 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; BEGIN { package Foo::Bar; use Test2::Util::HashBase qw/foo bar baz/; use Carp qw/croak/; sub init { my $self = shift; croak "'foo' is a required attribute" unless $self->{+FOO}; } } skip_all("known to fail on $]") if $] le "5.006002"; $@ = ""; my ($file, $line) = (__FILE__, __LINE__ + 1); eval { my $one = Foo::Bar->new }; my $err = $@; like( $err, qr/^'foo' is a required attribute at \Q$file\E line $line/, "Croak does not report to HashBase from init" ); done_testing; Test-Simple-1.302125/t/Test2/behavior/intercept.t0000644000175000017500000000213513243466361021273 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept intercept_deep context run_subtest/; sub streamed { my $name = shift; my $code = shift; my $ctx = context(); my $pass = run_subtest("Subtest: $name", $code, {buffered => 0}, @_); $ctx->release; return $pass; } sub buffered { my $name = shift; my $code = shift; my $ctx = context(); my $pass = run_subtest($name, $code, {buffered => 1}, @_); $ctx->release; return $pass; } my $subtest = sub { ok(1, "pass") }; my $buffered_shallow = intercept { buffered 'buffered shallow' => $subtest }; my $streamed_shallow = intercept { streamed 'streamed shallow' => $subtest }; my $buffered_deep = intercept_deep { buffered 'buffered shallow' => $subtest }; my $streamed_deep = intercept_deep { streamed 'streamed shallow' => $subtest }; is(@$buffered_shallow, 1, "Just got the subtest event"); is(@$streamed_shallow, 2, "Got note, and subtest events"); is(@$buffered_deep, 3, "Got ok, plan, and subtest events"); is(@$streamed_deep, 4, "Got note, ok, plan, and subtest events"); done_testing; Test-Simple-1.302125/t/Test2/behavior/Formatter.t0000644000175000017500000000321513243466361021241 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept run_subtest test2_stack/; use Test2::Event::Bail; { package Formatter::Subclass; use base 'Test2::Formatter'; use Test2::Util::HashBase qw{f t}; sub init { my $self = shift; $self->{+F} = []; $self->{+T} = []; } sub write { } sub hide_buffered { 1 } sub terminate { my $s = shift; push @{$s->{+T}}, [@_]; } sub finalize { my $s = shift; push @{$s->{+F}}, [@_]; } } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); is(1, 1, 'test event 1'); is(2, 2, 'test event 2'); is(3, 2, 'test event 3'); done_testing; }; is(scalar @{$f->f}, 1, 'finalize method was called on formatter'); is_deeply( $f->f->[0], [3, 3, 1, 0, 0], 'finalize method received expected arguments' ); ok(!@{$f->t}, 'terminate method was not called on formatter'); } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); $hub->send(Test2::Event::Bail->new(reason => 'everything is terrible')); done_testing; }; is(scalar @{$f->t}, 1, 'terminate method was called because of bail event'); ok(!@{$f->f}, 'finalize method was not called on formatter'); } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); $hub->send(Test2::Event::Plan->new(directive => 'skip_all', reason => 'Skipping all the tests')); done_testing; }; is(scalar @{$f->t}, 1, 'terminate method was called because of plan skip_all event'); ok(!@{$f->f}, 'finalize method was not called on formatter'); } done_testing; Test-Simple-1.302125/t/Test2/behavior/err_var.t0000644000175000017500000000026113243466361020734 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; { local $! = 100; is(0 + $!, 100, 'set $!'); is(0 + $!, 100, 'preserved $!'); } done_testing; Test-Simple-1.302125/t/Test2/behavior/Taint.t0000644000175000017500000000054413243466361020357 0ustar exodistexodist#!/usr/bin/env perl -T # HARNESS-NO-FORMATTER use Test2::API qw/context/; sub ok($;$@) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; return $bool ? 1 : 0; } sub done_testing { my $ctx = context(); $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } ok(1); ok(1); done_testing; Test-Simple-1.302125/t/Test2/modules/0000755000175000017500000000000013243466361016761 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/EventFacet/0000755000175000017500000000000013243466361021005 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/EventFacet/Control.t0000644000175000017500000000132613243466361022614 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Control'; my $CLASS = 'Test2::EventFacet::Control'; my $one = $CLASS->new(details => 'foo', global => 0, terminate => undef, halt => 0, has_callback => 1, encoding => 'utf8'); is($one->details, "foo", "Got details"); is($one->global, 0, "Got 'global' value"); is($one->terminate, undef, "Got 'terminate' value"); is($one->halt, 0, "Got 'halt' value"); is($one->has_callback, 1, "Got 'has_callback' value"); is($one->encoding, 'utf8', "Got 'utf8' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'control', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Amnesty.t0000644000175000017500000000100013243466361022601 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Amnesty'; my $CLASS = 'Test2::EventFacet::Amnesty'; my $one = $CLASS->new(details => 'foo', tag => 'bar', inherited => 0); is($one->details, "foo", "Got details"); is($one->tag, "bar", "Got tag"); is($one->inherited, 0, "Got 'inherited' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'amnesty', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Parent.t0000644000175000017500000000111613243466361022422 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Parent'; my $CLASS = 'Test2::EventFacet::Parent'; my $one = $CLASS->new(details => 'foo', hid => 'abc', children => [], buffered => 1); is($one->details, "foo", "Got details"); is($one->hid, 'abc', "Got 'hid' value"); is($one->buffered, 1, "Got 'buffered' value"); is_deeply($one->children, [], "Got 'children' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'parent', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Assert.t0000644000175000017500000000100213243466361022424 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Assert'; my $CLASS = 'Test2::EventFacet::Assert'; my $one = $CLASS->new(details => 'foo', pass => 1, no_debug => 1); is($one->details, "foo", "Got details"); is($one->pass, 1, "Got 'pass' value"); is($one->no_debug, 1, "Got 'no_debug' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'assert', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Trace.t0000644000175000017500000000232713243466361022234 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; my $CLASS = 'Test2::EventFacet::Trace'; like( exception { $CLASS->new() }, qr/The 'frame' attribute is required/, "got error" ); my $one = $CLASS->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); is($one->file, 'foo.t', "Got file"); is($one->line, 5, "Got line"); is($one->subname, 'Foo::Bar::foo', "got subname"); is($one->debug, "at foo.t line 5", "got trace"); $one->set_detail("yo momma"); is($one->debug, "yo momma", "got detail for trace"); $one->set_detail(undef); is( exception { $one->throw('I died') }, "I died at foo.t line 5.\n", "got exception" ); is_deeply( warnings { $one->alert('I cried') }, [ "I cried at foo.t line 5.\n" ], "alter() warns" ); my $snap = $one->snapshot; is_deeply($snap, $one, "identical"); ok($snap != $one, "Not the same instance"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'trace', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Error.t0000644000175000017500000000076413243466361022272 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Error'; my $CLASS = 'Test2::EventFacet::Error'; my $one = $CLASS->new(details => 'foo', tag => 'uhg', fail => 1); is($one->details, "foo", "Got details"); is($one->tag, 'uhg', "Got 'tag' value"); is($one->fail, 1, "Got 'fail' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'errors', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/About.t0000644000175000017500000000101113243466361022235 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::About'; my $CLASS = 'Test2::EventFacet::About'; my $one = $CLASS->new(details => 'foo', package => 'bar', no_display => 0); is($one->details, "foo", "Got details"); is($one->package, "bar", "Got package"); is($one->no_display, 0, "Got no_display value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "Not a list"); is($CLASS->facet_key, 'about', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Plan.t0000644000175000017500000000105113243466361022061 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Plan'; my $CLASS = 'Test2::EventFacet::Plan'; my $one = $CLASS->new(details => 'foo', count => 100, skip => 1, none => 0); is($one->details, "foo", "Got details"); is($one->count, 100, "Got 'count' value"); is($one->skip, 1, "Got 'skip' value"); is($one->none, 0, "Got 'none' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'plan', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Meta.t0000644000175000017500000000122413243466361022057 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Meta'; my $CLASS = 'Test2::EventFacet::Meta'; my $one = $CLASS->new(details => 'foo', a => 1, b => 'bar', x => undef, set_details => 'xxx'); is($one->details, "foo", "Got details"); is($one->set_details, "xxx", "set_details is a regular field, not a writer"); is($one->a, 1, "Got 'a'"); is($one->b, 'bar', "Got 'b'"); is($one->x, undef, "Got 'x'"); is($one->blah, undef, "Vivified 'blah'"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'meta', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet/Info.t0000644000175000017500000000075313243466361022072 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Info'; my $CLASS = 'Test2::EventFacet::Info'; my $one = $CLASS->new(details => 'foo', tag => 'bar', debug => 0); is($one->details, "foo", "Got details"); is($one->tag, "bar", "Got tag"); is($one->debug, 0, "Got 'debug' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'info', "Got key"); done_testing; Test-Simple-1.302125/t/Test2/modules/Formatter/0000755000175000017500000000000013243466361020724 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Formatter/TAP.t0000644000175000017500000007434713243466361021554 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-PRELOAD my $CLASS; my %BEFORE_LOAD; BEGIN { my $old = select STDOUT; $BEFORE_LOAD{STDOUT} = $|; select STDERR; $BEFORE_LOAD{STDERR} = $|; select $old; require Test2::Formatter::TAP; $CLASS = 'Test2::Formatter::TAP'; *OUT_STD = $CLASS->can('OUT_STD') or die "Could not get OUT_STD constant"; *OUT_ERR = $CLASS->can('OUT_ERR') or die "Could not get OUT_ERR constant"; } use Test2::Tools::Tiny; use Test2::API qw/context/; BEGIN { eval { require PerlIO; PerlIO->VERSION(1.02); # required for PerlIO::get_layers } or do { print "1..0 # SKIP Don't have PerlIO 1.02\n"; exit 0; } } sub grabber { my ($std, $err); open( my $stdh, '>', \$std ) || die "Ooops"; open( my $errh, '>', \$err ) || die "Ooops"; my $it = $CLASS->new( handles => [$stdh, $errh, $stdh], ); return ($it, \$std, \$err); } tests "IO handle stuff" => sub { ok($CLASS->can($_), "$CLASS has the '$_' method") for qw/no_numbers handles/; ok($CLASS->isa('Test2::Formatter'), "$CLASS isa Test2::Formatter"); ok(!$BEFORE_LOAD{STDOUT}, "AUTOFLUSH was not on for STDOUT before load"); ok(!$BEFORE_LOAD{STDERR}, "AUTOFLUSH was not on for STDERR before load"); my $old = select STDOUT; ok($|, "AUTOFLUSH was turned on for STDOUT"); select STDERR; ok($|, "AUTOFLUSH was turned on for STDERR"); select $old; ok(my $one = $CLASS->new, "Created a new instance"); my $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); ok($handles->[0] != $handles->[1], "First and second handles are not the same"); my $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[0])}; if (${^UNICODE} & 2) { # 2 means STDIN ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on"); } else { ok(!$layers->{utf8}, "Not utf8 by default"); } $one->encoding('utf8'); is($one->encoding, 'utf8', "Got encoding"); $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; ok($layers->{utf8}, "Now utf8"); my $two = $CLASS->new(encoding => 'utf8'); $handles = $two->handles; is(@$handles, 2, "Got 2 handles"); $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; ok($layers->{utf8}, "Now utf8"); $old = select $handles->[OUT_STD]; ok($|, "AUTOFLUSH was turned on for copy-STDOUT"); select select $handles->[OUT_ERR]; ok($|, "AUTOFLUSH was turned on for copy-STDERR"); select $old; ok($CLASS->hide_buffered, "TAP will hide buffered events"); ok(!$CLASS->no_subtest_space, "Default formatter does not have subtest space"); }; tests optimal_pass => sub { my ($it, $out, $err) = grabber(); my $fail = Test2::Event::Fail->new; ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); $fail = Test2::Event::Ok->new(pass => 0); ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); my $pass = Test2::Event::Pass->new(); $pass->add_amnesty({tag => 'foo', details => 'foo'}); ok(!$it->print_optimal_pass($pass, 1), "Not gonna print amnesty"); $pass = Test2::Event::Ok->new(pass => 1, todo => ''); ok(!$it->print_optimal_pass($pass, 1), "Not gonna print todo (even empty todo)"); $pass = Test2::Event::Ok->new(pass => 1, name => "foo # bar"); ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a hash"); $pass = Test2::Event::Ok->new(pass => 1, name => "foo \n bar"); ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a newline"); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); $pass = Test2::Event::Pass->new(); ok($it->print_optimal_pass($pass, 1), "Printed a simple pass without a name"); $pass = Test2::Event::Pass->new(name => 'xxx'); ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); $pass = Test2::Event::Ok->new(pass => 1, name => 'xxx'); ok($it->print_optimal_pass($pass, 1), "Printed an 'Ok' pass with a name"); $pass = Test2::Event::Pass->new(name => 'xxx', trace => { nested => 1 }); ok($it->print_optimal_pass($pass, 1), "Printed a nested pass"); $pass = Test2::Event::Pass->new(name => 'xxx', trace => { nested => 3 }); ok($it->print_optimal_pass($pass, 1), "Printed a deeply nested pass"); $pass = Test2::Event::Pass->new(name => 'xxx'); $it->{no_numbers} = 1; ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); is($$out, <<" EOT", "Got expected TAP output"); ok 1 ok 1 - xxx ok 1 - xxx ok 1 - xxx ok 1 - xxx ok - xxx EOT is($it->{_last_fh}, $it->handles->[OUT_STD], "Set the last filehandle"); ok(!$$err, "No err output"); }; tests plan_tap => sub { my ($it, $out, $err) = grabber(); is_deeply([$it->plan_tap({})], [], "Nothing with no plan facet"); is_deeply( [$it->plan_tap({plan => { none => 1 }})], [], "no-plan has no output" ); is_deeply( [$it->plan_tap({plan => { count => 20 }})], [[OUT_STD, "1..20\n"]], "Wrote the plan from, count" ); is_deeply( [$it->plan_tap({plan => { count => 'anything', skip => 1 }})], [[OUT_STD, "1..0 # SKIP\n"]], "Skip, no reason" ); is_deeply( [$it->plan_tap({plan => { count => 'anything', skip => 1, details => 'I said so' }})], [[OUT_STD, "1..0 # SKIP I said so\n"]], "Skip with reason" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests assert_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->assert_tap({assert => {pass => 1}}, 1)], [[OUT_STD, "ok 1\n"]], "Pass", ); is_deeply( [$it->assert_tap({assert => {pass => 0}}, 1)], [[OUT_STD, "not ok 1\n"]], "Fail", ); tests amnesty => sub { tests pass_no_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "ok 1 # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "ok 1 # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "ok 1 # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # foo xxx\n"]], "Pass with other amnesty", ); }; tests pass_with_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "ok 1 - bob # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "ok 1 - bob # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "ok 1 - bob # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # foo xxx\n"]], "Pass with other amnesty", ); }; tests fail_no_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "not ok 1 # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "not ok 1 # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 0}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "not ok 1 # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # foo xxx\n"]], "Pass with other amnesty", ); }; tests fail_with_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "not ok 1 - bob # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "not ok 1 - bob # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 0, details => 'bob'}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "not ok 1 - bob # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # foo xxx\n"]], "Pass with other amnesty", ); }; }; tests newline_and_hash => sub { tests pass => sub { is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}}, 1)], [ [OUT_STD, "ok 1 - foo\n"], [OUT_STD, "# bar\n"], ], "Pass with newline", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "ok 1 - foo # baz bat\n"], [OUT_STD, "# bar\n"], ], "Pass with newline and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}}, 1)], [[OUT_STD, "ok 1 - foo\\#bar\n"]], "Pass with hash", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [[OUT_STD, "ok 1 - foo\\#bar # baz bat\n"]], "Pass with hash and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}}, 1)], [ [OUT_STD, "ok 1 - foo\\#x\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "ok 1 - foo\\#x # baz bat\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash and amnesty", ); }; tests fail => sub { is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}}, 1)], [ [OUT_STD, "not ok 1 - foo\n"], [OUT_STD, "# bar\n"], ], "Pass with newline", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "not ok 1 - foo # baz bat\n"], [OUT_STD, "# bar\n"], ], "Pass with newline and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}}, 1)], [[OUT_STD, "not ok 1 - foo\\#bar\n"]], "Pass with hash", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [[OUT_STD, "not ok 1 - foo\\#bar # baz bat\n"]], "Pass with hash and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}}, 1)], [ [OUT_STD, "not ok 1 - foo\\#x\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "not ok 1 - foo\\#x # baz bat\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash and amnesty", ); }; }; tests parent => sub { is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, parent => {hid => 1, buffered => 1, children => [{assert => {pass => 1, details => 'bob2'}}]}, }, 1 ) ], [ [OUT_STD, "ok 1 - bob {\n"], [OUT_STD, " ok 1 - bob2\n"], [OUT_STD, "}\n"], ], "Parent (buffered)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, parent => {hid => 1, buffered => 0, children => [{assert => {pass => 1, details => 'bob2'}}]}, }, 1 ) ], [[OUT_STD, "ok 1 - bob\n"]], "Parent (un-buffered)", ); }; ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests debug_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [ $it->debug_tap( { assert => {pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, }, 1 ) ], [ [OUT_ERR, "# Failed test at foo.t line 42.\n"], ], "debug tap, nameless test" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], ], "Debug tap, named test" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42], details => 'I say hi!'}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# I say hi!\n"], ], "Debug tap with details" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# [No trace info available]\n"], ], "Debug tap no trace" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, amnesty => [], }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], ], "Debug empty amnesty" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, amnesty => [{tag => 'TODO', details => 'xxx'}], }, 1 ) ], [ [OUT_STD, "# Failed test (with amnesty) 'foo bar'\n# at foo.t line 42.\n"], ], "Debug empty amnesty" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); my $event = Test2::Event::Fail->new(trace => {frame => ['foo', 'foo.pl', 42]}); { local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; $event->{name} = 'no harness'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 0; $ENV{HARNESS_IS_VERBOSE} = 1; $event->{name} = 'no harness, but strangely verbose'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_IS_VERBOSE} = 0; $event->{name} = 'harness, but not verbose'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_IS_VERBOSE} = 1; $event->{name} = 'harness that is verbose'; $it->write($event, 1); } is($$out, <<" EOT", "Got 4 failures to STDERR"); not ok 1 - no harness not ok 1 - no harness, but strangely verbose not ok 1 - harness, but not verbose not ok 1 - harness that is verbose EOT is($$err, <<" EOT", "Got expected diag to STDERR, newline for non-verbose harness"); # Failed test 'no harness' # at foo.pl line 42. # Failed test 'no harness, but strangely verbose' # at foo.pl line 42. # Failed test 'harness, but not verbose' # at foo.pl line 42. # Failed test 'harness that is verbose' # at foo.pl line 42. EOT }; tests halt_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->halt_tap({trace => {nested => 1},})], [], "No output when nested" ); is_deeply( [$it->halt_tap({trace => {nested => 1, buffered => 1}})], [[OUT_STD, "Bail out!\n" ]], "Got tap for nested buffered bail" ); is_deeply( [$it->halt_tap({control => {details => ''}})], [[OUT_STD, "Bail out!\n"]], "Empty details" ); is_deeply( [$it->halt_tap({control => {details => undef}})], [[OUT_STD, "Bail out!\n"]], "undef details" ); is_deeply( [$it->halt_tap({control => {details => 0}})], [[OUT_STD, "Bail out! 0\n"]], "falsy details" ); is_deeply( [$it->halt_tap({control => {details => 'foo bar baz'}})], [[OUT_STD, "Bail out! foo bar baz\n"]], "full details" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests summary_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->summary_tap({about => { no_display => 1, details => "Should not see me"}})], [], "no display" ); is_deeply( [$it->summary_tap({about => { no_display => 0, details => ""}})], [], "no summary" ); is_deeply( [$it->summary_tap({about => { no_display => 0, details => "foo bar"}})], [[OUT_STD, "# foo bar\n"]], "summary" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests info_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [ $it->info_tap( { info => [ {debug => 0, details => "foo"}, {debug => 1, details => "foo"}, {debug => 0, details => "foo\nbar\nbaz"}, {debug => 1, details => "foo\nbar\nbaz"}, ] } ) ], [ [OUT_STD, "# foo\n"], [OUT_ERR, "# foo\n"], [OUT_STD, "# foo\n# bar\n# baz\n"], [OUT_ERR, "# foo\n# bar\n# baz\n"], ], "Got all infos" ); my @TAP = $it->info_tap( { info => [ {debug => 0, details => {structure => 'yes'}}, {debug => 1, details => {structure => 'yes'}}, ] } ); is($TAP[0]->[0], OUT_STD, "First went to STDOUT"); is($TAP[1]->[0], OUT_ERR, "Second went to STDOUT"); like($TAP[0]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); like($TAP[1]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests error_tap => sub { my ($it, $out, $err) = grabber(); # Data::Dumper behavior can change from version to version, specifically # the Data::Dumper in 5.8.9 produces different whitespace from other # versions. require Data::Dumper; my $dumper = Data::Dumper->new([{structure => 'yes'}])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp(my $struct = $dumper->Dump); is_deeply( [ $it->error_tap( { errors => [ {details => "foo"}, {details => "foo\nbar\nbaz"}, {details => {structure => 'yes'}}, ] } ) ], [ [OUT_ERR, "# foo\n"], [OUT_ERR, "# foo\n# bar\n# baz\n"], [OUT_ERR, "$struct\n"], ], "Got all errors" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests event_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 1)], [ [OUT_STD, "1..5\n"], [OUT_STD, "ok 1\n"], ], "Plan then assertion for first assertion" ); $it->{made_assertion} = 1; is_deeply( [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 2)], [ [OUT_STD, "ok 2\n"], [OUT_STD, "1..5\n"], ], "Assertion then plan for additional assertions" ); $it->{made_assertion} = 0; is_deeply( [ $it->event_tap( { plan => {count => 5}, assert => {pass => 0}, errors => [{details => "foo"}], info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, 1 ) ], [ [OUT_STD, "1..5\n"], [OUT_STD, "not ok 1\n"], [OUT_ERR, "# Failed test [No trace info available]\n"], [OUT_ERR, "# foo\n"], [OUT_ERR, "# xxx\n"], [OUT_STD, "# yyy\n"], [OUT_STD, "Bail out! blah\n"], ], "All facets displayed" ); is_deeply( [ $it->event_tap( { plan => {count => 5}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "1..5\n"]], "Plan blocks details" ); is_deeply( [ $it->event_tap( { assert => {pass => 0, no_debug => 1}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "not ok 1\n"]], "Assert blocks details" ); is_deeply( [ $it->event_tap( { errors => [{details => "foo"}], about => {details => 'xyz'}, }, 1 ) ], [[OUT_ERR, "# foo\n"]], "Error blocks details" ); is_deeply( [ $it->event_tap( { info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], about => {details => 'xyz'}, }, 1 ) ], [ [OUT_ERR, "# xxx\n"], [OUT_STD, "# yyy\n"], ], "Info blocks details" ); is_deeply( [ $it->event_tap( { control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "Bail out! blah\n"]], "Halt blocks details" ); is_deeply( [$it->event_tap({about => {details => 'xyz'}}, 1)], [[OUT_STD, "# xyz\n"]], "Fallback to summary" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests write => sub { my ($it, $out, $err) = grabber(); local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; { local $\ = 'oops1'; local $, = 'oops2'; $it->write( undef, 1, { plan => {count => 5}, assert => {pass => 0}, errors => [{details => "foo"}], info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, ); $it->write(undef, 2, {assert => {pass => 1}, trace => {nested => 1}}); } is($it->{_last_fh}, $it->handles->[OUT_STD], "Set last handle"); is($$out, <<" EOT", "STDOUT is as expected"); 1..5 not ok 1 # yyy Bail out! blah ok 2 EOT is($$err, <<" EOT", "STDERR is as expected"); # Failed test [No trace info available] # foo # xxx EOT }; done_testing; Test-Simple-1.302125/t/Test2/modules/Hub/0000755000175000017500000000000013243466361017477 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Hub/Interceptor/0000755000175000017500000000000013243466361021775 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Hub/Interceptor/Terminator.t0000644000175000017500000000024713243466361024311 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Interceptor::Terminator; ok($INC{'Test2/Hub/Interceptor/Terminator.pm'}, "loaded"); done_testing; Test-Simple-1.302125/t/Test2/modules/Hub/Interceptor.t0000644000175000017500000000057613243466361022172 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Interceptor; my $one = Test2::Hub::Interceptor->new(); ok($one->isa('Test2::Hub'), "inheritence");; my $e = exception { $one->terminate(55) }; ok($e->isa('Test2::Hub::Interceptor::Terminator'), "exception type"); like($$e, 'Label not found for "last T2_SUBTEST_WRAPPER"', "Could not find label"); done_testing; Test-Simple-1.302125/t/Test2/modules/Hub/Subtest.t0000644000175000017500000000501713243466361021320 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Subtest; use Test2::Util qw/get_tid/; use Carp qw/croak/; my %TODO; sub def { my ($func, @args) = @_; my @caller = caller(0); $TODO{$caller[0]} ||= []; push @{$TODO{$caller[0]}} => [$func, \@args, \@caller]; } sub do_def { my $for = caller; my $tests = delete $TODO{$for} or croak "No tests to run!"; for my $test (@$tests) { my ($func, $args, $caller) = @$test; my ($pkg, $file, $line) = @$caller; # Note: The '&' below is to bypass the prototype, which is important here. eval <<" EOT" or die $@; package $pkg; # line $line "(eval in DeferredTests) $file" \&$func(\@\$args); 1; EOT } } my $ran = 0; my $event; my $one = Test2::Hub::Subtest->new( nested => 3, ); ok($one->isa('Test2::Hub'), "inheritence"); { no warnings 'redefine'; local *Test2::Hub::process = sub { $ran++; (undef, $event) = @_; 'P!' }; use warnings; my $ok = Test2::Event::Ok->new( pass => 1, name => 'blah', trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($ok), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $ok, "got our event"); def is => ($one->bailed_out, undef, "did not bail"); $ran = 0; $event = undef; my $bail = Test2::Event::Bail->new( message => 'blah', trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($bail), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $bail, "got our event"); } do_def; my $skip = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid), directive => 'SKIP', reason => 'foo', ); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->terminate(100, $skip); $ran++; } is($ran, 1, "did not get past the terminate"); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->send($skip); $ran++; } is($ran, 1, "did not get past the terminate"); $one->reset_state; $one->set_manual_skip_all(1); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->terminate(100, $skip); $ran++; } is($ran, 2, "did not automatically abort"); $one->reset_state; $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->send($skip); $ran++; } is($ran, 2, "did not automatically abort"); done_testing; Test-Simple-1.302125/t/Test2/modules/Tools/0000755000175000017500000000000013243466361020061 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Tools/Tiny.t0000644000175000017500000001157713243466361021204 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context intercept test2_stack/; ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{ ok is isnt like unlike diag note is_deeply warnings exception plan skip_all done_testing }; ok(1, "'ok' Test"); is("foo", "foo", "'is' test"); is(undef, undef, "'is' undef test"); isnt("foo", "bar", "'isnt' test"); isnt("foo", undef, "'isnt' undef test 1"); isnt(undef, "foo", "'isnt' undef test 2"); like("foo", qr/o/, "'like' test"); unlike("foo", qr/a/, "'unlike' test"); note("Testing Note"); my $str = "abc"; is_deeply( { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}}, { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}}, "'is_deeply' test" ); is_deeply( warnings { warn "aaa\n"; warn "bbb\n" }, [ "aaa\n", "bbb\n" ], "Got warnings" ); is_deeply( warnings { 1 }, [], "no warnings" ); is(exception { die "foo\n" }, "foo\n", "got exception"); is(exception { 1 }, undef, "no exception"); my $main_events = intercept { plan 8; ok(0, "'ok' Test"); is("foo", "bar", "'is' test"); isnt("foo", "foo", "'isnt' test"); like("foo", qr/a/, "'like' test"); unlike("foo", qr/o/, "'unlike' test"); is_deeply( { a => 1, b => 2, c => {}}, { a => 1, b => 2, c => []}, "'is_deeply' test" ); }; my $other_events = intercept { diag("Testing Diag"); note("Testing Note"); }; my ($plan, $ok, $is, $isnt, $like, $unlike, $is_deeply) = grep {!$_->isa('Test2::Event::Diag')} @$main_events; my ($diag, $note) = @$other_events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); ok($ok->isa('Test2::Event::Fail'), "got 'ok' result"); is($ok->facets->{assert}->pass, 0, "'ok' test failed"); ok($is->isa('Test2::Event::Fail'), "got 'is' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($isnt->isa('Test2::Event::Fail'), "got 'isnt' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($like->isa('Test2::Event::Fail'), "got 'like' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($unlike->isa('Test2::Event::Fail'), "got 'unlike' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($is_deeply->isa('Test2::Event::Fail'), "got 'is_deeply' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); ok($note->isa('Test2::Event::Note'), "got 'note' result"); is($note->message, "Testing Note", "got note message"); my $events = intercept { skip_all 'because'; ok(0, "should not see me"); die "should not happen"; }; is(@$events, 1, "1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); is($events->[0]->directive, 'SKIP', "plan is skip"); is($events->[0]->reason, 'because', "skip reason"); $events = intercept { is(undef, ""); is("", undef); isnt(undef, undef); like(undef, qr//); unlike(undef, qr//); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is(@$events, 5, "5 events"); ok(!$_->facets->{assert}->pass, "undef test - should not pass") for @$events; sub tool { context() }; my %params; my $ctx = context(level => -1); my $ictx; $events = intercept { %params = @_; $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); my $trace = Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is_deeply( \%params, { context => { %$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef }, hub => $ictx->hub, }, "Passed in some useful params" ); ok($ctx != $ictx, "Different context inside intercept"); is(@$events, 3, "got 3 events"); $ctx->release; $ictx->release; # Test that a bail-out in an intercept does not exit. $events = intercept { $ictx = tool(); $ictx->bail("The world ends"); $ictx->ok(0, "Should not see this"); }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); $events = intercept { $ictx = tool(); }; $ictx->release; like( exception { intercept { die 'foo' } }, qr/foo/, "Exception was propogated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; Test-Simple-1.302125/t/Test2/modules/IPC/0000755000175000017500000000000013243466361017374 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/IPC/Driver/0000755000175000017500000000000013243466361020627 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/IPC/Driver/Files.t0000644000175000017500000004121113243466361022055 0ustar exodistexodistuse Test2::Tools::Tiny; use Test2::Util qw/get_tid USE_THREADS try ipc_separator/; use File::Temp qw/tempfile/; use File::Spec qw/catfile/; use List::Util qw/shuffle/; use strict; use warnings; if ($] lt "5.008") { print "1..0 # SKIP Test cannot run on perls below 5.8.0\n"; exit 0; } sub simple_capture(&) { my $code = shift; my ($err, $out) = ("", ""); my ($ok, $e); { local *STDOUT; local *STDERR; ($ok, $e) = try { open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!"; $code->(); }; } die $e unless $ok; return { STDOUT => $out, STDERR => $err, }; } require Test2::IPC::Driver::Files; ok(my $ipc = Test2::IPC::Driver::Files->new, "Created an IPC instance"); ok($ipc->isa('Test2::IPC::Driver::Files'), "Correct type"); ok($ipc->isa('Test2::IPC::Driver'), "inheritence"); ok(-d $ipc->tempdir, "created temp dir"); is($ipc->pid, $$, "stored pid"); is($ipc->tid, get_tid(), "stored the tid"); my $hid = join ipc_separator, qw'12345 1 1'; $ipc->add_hub($hid); my $hubfile = File::Spec->catfile($ipc->tempdir, "HUB" . ipc_separator . $hid); ok(-f $hubfile, "wrote hub file"); if(ok(open(my $fh, '<', $hubfile), "opened hub file")) { my @lines = <$fh>; close($fh); is_deeply( \@lines, [ "$$\n", get_tid() . "\n" ], "Wrote pid and tid to hub file" ); } { package Foo; use base 'Test2::Event'; } $ipc->send($hid, bless({ foo => 1 }, 'Foo')); $ipc->send($hid, bless({ bar => 1 }, 'Foo')); my $sep = ipc_separator; opendir(my $dh, $ipc->tempdir) || die "Could not open tempdir: !?"; my @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB${sep}$hid/ } readdir($dh); closedir($dh); is(@files, 2, "2 files added to the IPC directory"); my @events = $ipc->cull($hid); is_deeply( \@events, [{ foo => 1 }, { bar => 1 }], "Culled both events" ); opendir($dh, $ipc->tempdir) || die "Could not open tempdir: !?"; @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB$sep$hid/ } readdir($dh); closedir($dh); is(@files, 0, "All files collected"); $ipc->drop_hub($hid); ok(!-f $ipc->tempdir . '/' . $hid, "removed hub file"); $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); my @got = $ipc->cull($hid); ok(@got == 0, "did not get our own global event"); my $tmpdir = $ipc->tempdir; ok(-d $tmpdir, "still have temp dir"); $ipc = undef; ok(!-d $tmpdir, "cleaned up temp dir"); { my $ipc = Test2::IPC::Driver::Files->new(); my $tmpdir = $ipc->tempdir; my $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_thread_clone->set_tid(100); $ipc_thread_clone = undef; ok(-d $tmpdir, "Directory not removed (different thread)"); my $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_fork_clone->set_pid($$ + 10); $ipc_fork_clone = undef; ok(-d $tmpdir, "Directory not removed (different proc)"); $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_thread_clone->set_tid(undef); $ipc_thread_clone = undef; ok(-d $tmpdir, "Directory not removed (no thread)"); $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_fork_clone->set_pid(undef); $ipc_fork_clone = undef; ok(-d $tmpdir, "Directory not removed (no proc)"); $ipc = undef; ok(!-d $tmpdir, "Directory removed"); } { no warnings qw/once redefine/; local *Test2::IPC::Driver::Files::driver_abort = sub {}; local *Test2::IPC::Driver::Files::abort = sub { my $self = shift; local $self->{no_fatal} = 1; local $self->{no_bail} = 1; $self->Test2::IPC::Driver::abort(@_); die 255; }; my $tmpdir; my @lines; my $file = __FILE__; my $out = simple_capture { local $ENV{T2_KEEP_TEMPDIR} = 1; my $ipc = Test2::IPC::Driver::Files->new(); $tmpdir = $ipc->tempdir; $ipc->add_hub($hid); eval { $ipc->add_hub($hid) }; push @lines => __LINE__; $ipc->send($hid, bless({ foo => 1 }, 'Foo')); $ipc->cull($hid); $ipc->drop_hub($hid); eval { $ipc->drop_hub($hid) }; push @lines => __LINE__; # Make sure having a hub file sitting around does not throw things off # in T2_KEEP_TEMPDIR $ipc->add_hub($hid); $ipc = undef; 1; }; my $cleanup = sub { if (opendir(my $d, $tmpdir)) { for my $f (readdir($d)) { next if $f =~ m/^\.+$/; my $file = File::Spec->catfile($tmpdir, $f); next unless -f $file; 1 while unlink $file; } closedir($d); rmdir($tmpdir) or warn "Could not remove temp dir '$tmpdir': $!"; } }; $cleanup->(); like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path"); like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' already exists/m, "Got message for duplicate hub"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' does not exist/m, "Cannot remove hub twice"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 }; print STDERR $@ unless $e || $@ =~ m/^255/; $ipc->drop_hub($hid); }; like($out->{STDERR}, qr/IPC Fatal Error:/, "Got fatal error"); like($out->{STDERR}, qr/There was an error writing an event/, "Explanation"); like($out->{STDERR}, qr/Destination: $hid/, "Got dest"); like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid"); like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); local $@; eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) }; print STDERR $@ unless $@ =~ m/^255/; $ipc = undef; }; like($out->{STDERR}, qr/IPC Fatal Error: hub '$hid' is not available, failed to send event!/, "Cannot send to missing hub"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $tmpdir = $ipc->tempdir; $ipc->add_hub($hid); $ipc->send($hid, bless({ foo => 1 }, 'Foo')); local $@; eval { $ipc->drop_hub($hid) }; print STDERR $@ unless $@ =~ m/^255/; }; $cleanup->(); like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '$hid' have been collected/, "Leftover files"); like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); eval { $ipc->send($hid, { foo => 1 }) }; print STDERR $@ unless $@ =~ m/^255/; eval { $ipc->send($hid, bless({ foo => 1 }, 'xxx')) }; print STDERR $@ unless $@ =~ m/^255/; }; like($out->{STDERR}, qr/IPC Fatal Error: 'HASH\(.*\)' is not a blessed object/, "Cannot send unblessed objects"); like($out->{STDERR}, qr/IPC Fatal Error: 'xxx=HASH\(.*\)' is not an event object!/, "Cannot send non-event objects"); $ipc = Test2::IPC::Driver::Files->new(); my ($fh, $fn) = tempfile(); print $fh "\n"; close($fh); Storable::store({}, $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr/IPC Fatal Error: Got an unblessed object: 'HASH\(.*\)'/, "Events must actually be events (must be blessed)" ); Storable::store(bless({}, 'Test2::Event::FakeEvent'), $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr{IPC Fatal Error: Event has unknown type \(Test2::Event::FakeEvent\), tried to load 'Test2/Event/FakeEvent\.pm' but failed: Can't locate Test2/Event/FakeEvent\.pm}, "Events must actually be events (not a real module)" ); Storable::store(bless({}, 'Test2::API'), $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr{'Test2::API=HASH\(.*\)' is not a 'Test2::Event' object}, "Events must actually be events (not an event type)" ); Storable::store(bless({}, 'Foo'), $fn); $out = simple_capture { local @INC; push @INC => ('t/lib', 'lib'); eval { $ipc->read_event_file($fn) }; }; ok(!$out->{STDERR}, "no problem", $out->{STDERR}); ok(!$out->{STDOUT}, "no problem", $out->{STDOUT}); unlink($fn); } { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); $ipc->set_globals({}); my @events = $ipc->cull($hid); is_deeply( \@events, [ {global => 1} ], "Got global event" ); @events = $ipc->cull($hid); ok(!@events, "Did not grab it again"); $ipc->set_globals({}); @events = $ipc->cull($hid); is_deeply( \@events, [ {global => 1} ], "Still there" ); $ipc->drop_hub($hid); $ipc = undef; } { my @list = shuffle ( {global => 0, pid => 2, tid => 1, eid => 1}, {global => 0, pid => 2, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 1, eid => 3}, {global => 1, pid => 1, tid => 1, eid => 1}, {global => 1, pid => 12, tid => 1, eid => 3}, {global => 1, pid => 11, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 3, eid => 1}, {global => 0, pid => 2, tid => 3, eid => 10}, {global => 0, pid => 2, tid => 3, eid => 100}, {global => 0, pid => 5, tid => 3, eid => 2}, {global => 0, pid => 5, tid => 3, eid => 20}, {global => 0, pid => 5, tid => 3, eid => 200}, ); my @sorted; { package Test2::IPC::Driver::Files; @sorted = sort cmp_events @list; } is_deeply( \@sorted, [ {global => 1, pid => 1, tid => 1, eid => 1}, {global => 1, pid => 11, tid => 1, eid => 2}, {global => 1, pid => 12, tid => 1, eid => 3}, {global => 0, pid => 2, tid => 1, eid => 1}, {global => 0, pid => 2, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 1, eid => 3}, {global => 0, pid => 2, tid => 3, eid => 1}, {global => 0, pid => 2, tid => 3, eid => 10}, {global => 0, pid => 2, tid => 3, eid => 100}, {global => 0, pid => 5, tid => 3, eid => 2}, {global => 0, pid => 5, tid => 3, eid => 20}, {global => 0, pid => 5, tid => 3, eid => 200}, ], "Sort by global, pid, tid and then eid" ); } { my $ipc = 'Test2::IPC::Driver::Files'; is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready.complete'), { ready => 1, complete => 1, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global complete" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready'), { ready => 1, complete => 0, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo'), { ready => 0, complete => 0, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global not ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'1 1 1 123 456 789 Event Type Foo.ready.complete'), { ready => 1, complete => 1, global => 0, type => "Event::Type::Foo", hid => "1${sep}1${sep}1", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'1 1 1 123 456 789 Event Type Foo', }, "Parsed event complete" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'1 2 3 123 456 789 Event Type Foo.ready'), { ready => 1, complete => 0, global => 0, type => "Event::Type::Foo", hid => "1${sep}2${sep}3", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'1 2 3 123 456 789 Event Type Foo', }, "Parsed event ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'3 2 11 123 456 789 Event'), { ready => 0, complete => 0, global => 0, type => "Event", hid => "3${sep}2${sep}11", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'3 2 11 123 456 789 Event', }, "Parsed event not ready" ); } { my $ipc = Test2::IPC::Driver::Files->new(); my $hid = join ipc_separator, qw"1 1 1"; is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Do not read complete global" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready global the first time" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, 0, "Should not read ready global again" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo") ? 1 : 0, 0, "Should not read un-ready global" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Do not read complete our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready our hid (again, no duplicate checking)" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo") ? 1 : 0, 0, "Should not read un-ready our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Not ours - complete" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready") ? 1 : 0, 0, "Not ours - ready" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo") ? 1 : 0, 0, "Not ours - unready" ); my @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo"); ok(!@got, "return empty list for false"); @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"); is(@got, 1, "got 1 item on true"); like(delete $got[0]->{full_path}, qr{^.+\Q$hid\E${sep}123${sep}456${sep}789${sep}Event${sep}Type${sep}Foo\.ready$}, "Got full path"); is_deeply( $got[0], $ipc->parse_event_filename(join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"), "Apart from full_path we get entire parsed filename" ); $ipc = undef; } done_testing; Test-Simple-1.302125/t/Test2/modules/IPC/Driver.t0000644000175000017500000000260013243466361021012 0ustar exodistexodistuse strict; use warnings; use Test2::IPC::Driver::Files; use Test2::Tools::Tiny; use Test2::API qw/context test2_ipc_drivers/; Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Driver not added multiple times" ); for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { my $one = Test2::IPC::Driver->new; like( exception { $one->$meth }, qr/'\Q$one\E' did not define the required method '$meth'/, "Require override of method $meth" ); } SKIP: { last SKIP if $] lt "5.008"; tests abort => sub { my $one = Test2::IPC::Driver->new(no_fatal => 1); my ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort('foo'); } is($err, "IPC Fatal Error: foo\n", "Got error"); is($out, "Bail out! IPC Fatal Error: foo\n", "got 'bail-out' on stdout"); ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort_trace('foo'); } like($out, qr/Bail out! IPC Fatal Error: foo/, "got 'bail-out' on stdout"); like($err, qr/IPC Fatal Error: foo/, "Got error"); }; } done_testing; Test-Simple-1.302125/t/Test2/modules/Util/0000755000175000017500000000000013243466361017676 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Util/Facets2Legacy.t0000644000175000017500000001053713243466361022505 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Util::Facets2Legacy ':ALL'; my $CLASS; BEGIN { $CLASS = 'Test2::Util::Facets2Legacy'; # This private function is not exported, but we want to test it anyway *_get_facet_data = $CLASS->can('_get_facet_data'); } tests _get_facet_data => sub { my $pass = Test2::Event::Pass->new(name => 'xxx'); is_deeply( _get_facet_data($pass), { about => {package => 'Test2::Event::Pass', details => 'pass'}, assert => {pass => 1, details => 'xxx'}, }, "Got facet data from event" ); is_deeply( _get_facet_data({assert => {pass => 1}}), {assert => {pass => 1}}, "Facet data gets passed through" ); my $file = __FILE__; my $line; like( exception { $line = __LINE__; _get_facet_data([]) }, qr/'ARRAY\(.*\)' Does not appear to be either a Test::Event or an EventFacet hashref at \Q$file\E line $line/, "Must provide sane input data" ); { package Fake::Event; use base 'Test2::Event'; use Test2::Util::Facets2Legacy qw/causes_fail/; } my $e = Fake::Event->new(); like( exception { $line = __LINE__; $e->causes_fail }, qr/Cycle between Facets2Legacy and Fake::Event=HASH\(.*\)->facet_data\(\) \(Did you forget to override the facet_data\(\) method\?\)/, "Cannot depend on legacy facet_data and Facets2Legacy" ); }; tests causes_fail => sub { is(causes_fail({errors => [{fail => 1}]}), 1, "Fatal errors cause failure"); is(causes_fail({control => {terminate => 0}}), 0, "defined but 0 termination does not cause failure"); is(causes_fail({control => {terminate => 1}}), 1, "non-zero defined termination causes failure"); is(causes_fail({control => {halt => 1}}), 1, "A halt causes failure"); is(causes_fail({assert => {pass => 0}}), 1, "non-passign assert causes failure"); is(causes_fail({assert => {pass => 0}, amnesty => [{}]}), 0, "amnesty prevents assertion failure"); is(causes_fail({}), 0, "Default is no failure"); }; tests diagnostics => sub { is(diagnostics({}), 0, "Default is no"); is(diagnostics({errors => [{}]}), 1, "Errors mean diagnostics"); is(diagnostics({info => [{}]}), 0, "Info alone does not make diagnostics"); is(diagnostics({info => [{debug => 1}]}), 1, "Debug flag makes info diagnostics"); }; tests global => sub { is(global({}), 0, "not global by default"); is(global({control => {global => 0}}), 0, "global not set"); is(global({control => {global => 1}}), 1, "global is set"); }; tests increments_count => sub { is(increments_count({}), 0, "No count bump without an assertion"); is(increments_count({assert => {}}), 1, "count bump with assertion"); }; tests no_display => sub { is(no_display({}), 0, "default is no"); is(no_display({about => {no_display => 0}}), 0, "set to off"); is(no_display({about => {no_display => 1}}), 1, "set to on"); }; tests subtest_id => sub { is(subtest_id({}), undef, "none by default"); is(subtest_id({parent => {hid => 123}}), 123, "use parent hid when present"); }; tests summary => sub { is(summary({}), '', "no summary without about->details"); is(summary({about => {details => 'foo'}}), 'foo', "got about->details"); }; tests terminate => sub { is(terminate({}), undef, "undef by default"); is(terminate({control => {terminate => undef}}), undef, "undef by choice"); is(terminate({control => {terminate => 100}}), 100, "got the terminate value"); is(terminate({control => {terminate => 0}}), 0, "0 is passed through"); }; tests sets_plan => sub { is_deeply( [sets_plan({})], [], "No plan by default"); is_deeply( [sets_plan({plan => {}})], [0], "Empty plan means count of 0, nothing extra" ); is_deeply( [sets_plan({plan => {count => 100}})], [100], "Got simple count" ); is_deeply( [sets_plan({plan => {count => 0, none => 1}})], [0, 'NO PLAN'], "No Plan" ); is_deeply( [sets_plan({plan => {count => 0, skip => 1}})], [0, 'SKIP'], "Skip" ); is_deeply( [sets_plan({plan => {count => 0, skip => 1, details => 'foo bar'}})], [0, 'SKIP', 'foo bar'], "Skip with reason" ); }; done_testing; Test-Simple-1.302125/t/Test2/modules/Util/ExternalMeta.t0000644000175000017500000000347413243466361022464 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; { package Foo::Bar; use Test2::Util::ExternalMeta; use Test2::Util::HashBase qw/foo bar/; } ok(Foo::Bar->can($_), "Imported '$_'") for qw/meta get_meta set_meta delete_meta/; my $one = Foo::Bar->new(foo => 1, bar => 2); ok($one->isa('Foo::Bar'), "Got instance"); is_deeply($one, {foo => 1, bar => 2}, "nothing fishy.. yet"); is($one->get_meta('foo'), undef, "no meta-data for foo"); is($one->get_meta('bar'), undef, "no meta-data for bar"); is($one->get_meta('baz'), undef, "no meta-data for baz"); is($one->meta('foo'), undef, "no meta-data for foo"); is($one->meta('bar'), undef, "no meta-data for bar"); is($one->meta('baz'), undef, "no meta-data for baz"); is_deeply($one, {foo => 1, bar => 2}, "Still have not modified instance"); $one->set_meta('foo' => 123); is($one->foo, 1, "did not change attribute"); is($one->meta('foo'), 123, "get meta-data for foo"); is($one->get_meta('foo'), 123, "get meta-data for foo again"); $one->meta('foo', 345); is($one->foo, 1, "did not change attribute"); is($one->meta('foo', 678), 123, "did not alter already set meta-attribute"); is($one->get_meta('foo'), 123, "still did not alter already set meta-attribute"); is($one->meta('bar', 789), 789, "used default for bar"); is($one->bar, 2, "did not change attribute"); is_deeply( $one, { foo => 1, bar => 2, Test2::Util::ExternalMeta::META_KEY() => { foo => 123, bar => 789, }, }, "Stored meta-data" ); is($one->delete_meta('foo'), 123, "got old value on delete"); is($one->meta('foo'), undef, "no more value"); is_deeply( $one, { foo => 1, bar => 2, Test2::Util::ExternalMeta::META_KEY() => { bar => 789, }, }, "Deleted the meta key" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Util/Trace.t0000644000175000017500000000220313243466361021116 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; like( exception { 'Test2::EventFacet::Trace'->new() }, qr/The 'frame' attribute is required/, "got error" ); my $one = 'Test2::EventFacet::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); is($one->file, 'foo.t', "Got file"); is($one->line, 5, "Got line"); is($one->subname, 'Foo::Bar::foo', "got subname"); is($one->debug, "at foo.t line 5", "got trace"); $one->set_detail("yo momma"); is($one->debug, "yo momma", "got detail for trace"); $one->set_detail(undef); is( exception { $one->throw('I died') }, "I died at foo.t line 5.\n", "got exception" ); is_deeply( warnings { $one->alert('I cried') }, [ "I cried at foo.t line 5.\n" ], "alter() warns" ); my $snap = $one->snapshot; is_deeply($snap, $one, "identical"); ok($snap != $one, "Not the same instance"); done_testing; Test-Simple-1.302125/t/Test2/modules/EventFacet.t0000644000175000017500000000104513243466361021172 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet'; my $CLASS = 'Test2::EventFacet'; my $one = $CLASS->new(details => 'foo'); is($one->details, "foo", "Got details"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); my $two = $one->clone(details => 'bar'); is($one->details, 'foo', "Original details unchanged"); is($two->details, 'bar', "Clone details changed"); ok(!$CLASS->is_list, "Not a list by default"); ok(!$CLASS->facet_key, "No key for base class"); done_testing; Test-Simple-1.302125/t/Test2/modules/API/0000755000175000017500000000000013243466361017372 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/API/Instance.t0000644000175000017500000003444013243466361021330 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; ok(1, "Just to get things initialized."); # We need to control this env var for this test $ENV{T2_NO_IPC} = 0; # This test relies on TAP being the default formatter for non-canon instances $ENV{T2_FORMATTER} = 'TAP'; my $CLASS = 'Test2::API::Instance'; my $one = $CLASS->new; is_deeply( $one, { contexts => {}, finalized => undef, ipc => undef, formatter => undef, ipc_polling => undef, ipc_drivers => [], ipc_timeout => 30, ipc_disabled => 0, formatters => [], no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_acquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], pre_subtest_callbacks => [], stack => [], }, "Got initial settings" ); %$one = (); is_deeply($one, {}, "wiped object"); $one->reset; is_deeply( $one, { contexts => {}, ipc_polling => undef, ipc_drivers => [], ipc_timeout => 30, ipc_disabled => 0, formatters => [], finalized => undef, ipc => undef, formatter => undef, no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_acquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], pre_subtest_callbacks => [], stack => [], }, "Reset Object" ); ok(!$one->formatter_set, "no formatter set"); $one->set_formatter('Foo'); ok($one->formatter_set, "formatter set"); $one->reset; my $ran = 0; my $callback = sub { $ran++ }; $one->add_post_load_callback($callback); ok(!$ran, "did not run yet"); is_deeply($one->post_load_callbacks, [$callback], "stored callback for later"); ok(!$one->loaded, "not loaded"); $one->load; ok($one->loaded, "loaded"); is($ran, 1, "ran the callback"); $one->load; is($ran, 1, "Did not run the callback again"); $one->add_post_load_callback($callback); is($ran, 2, "ran the new callback"); is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record"); like( exception { $one->add_post_load_callback({}) }, qr/Post-load callbacks must be coderefs/, "Post-load callbacks must be coderefs" ); $one->reset; ok($one->ipc, 'got ipc'); ok($one->finalized, "calling ipc finalized the object"); $one->reset; ok($one->stack, 'got stack'); ok(!$one->finalized, "calling stack did not finaliz the object"); $one->reset; ok($one->formatter, 'Got formatter'); ok($one->finalized, "calling format finalized the object"); $one->reset; $one->set_formatter('Foo'); is($one->formatter, 'Foo', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); { local $ENV{T2_FORMATTER} = 'TAP'; $one->reset; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP'; $one->reset; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+A::Fake::Module::That::Should::Not::Exist'; $one->reset; like( exception { $one->formatter }, qr/COULD NOT LOAD FORMATTER 'A::Fake::Module::That::Should::Not::Exist' \(set by the 'T2_FORMATTER' environment variable\)/, "Bad formatter" ); } $ran = 0; $one->reset; $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 1, "added an exit callback"); $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 2, "added another exit callback"); like( exception { $one->add_exit_callback({}) }, qr/End callbacks must be coderefs/, "Exit callbacks must be coderefs" ); $one->reset; $one->add_pre_subtest_callback($callback); is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback"); $one->add_pre_subtest_callback($callback); is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback"); like( exception { $one->add_pre_subtest_callback({}) }, qr/Pre-subtest callbacks must be coderefs/, "Pre-subtest callbacks must be coderefs" ); if (CAN_REALLY_FORK) { $one->reset; my $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 0 } is(Test2::API::Instance::_ipc_wait, 0, "No errors"); $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 255 } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit"); $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { sleep 20; exit 0 } kill('TERM', $pid) or die "Failed to send signal"; @warnings = (); { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit"); } if (CAN_THREAD && $] ge '5.010') { require threads; $one->reset; threads->new(sub { 1 }); is(Test2::API::Instance::_ipc_wait, 0, "No errors"); if (threads->can('error')) { threads->new(sub { close(STDERR); close(STDOUT); die "xxx" }); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Thread exited badly"); } like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); } } { $one->reset(); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->set__tid(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->stack->top; $one->no_wait(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->stack->top->set_no_ending(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->load(); $one->stack->top->set_failed(2); local $? = 0; $one->set_exit; is($?, 2, "number of failures"); } { $one->reset(); $one->load(); local $? = 500; $one->set_exit; is($?, 255, "set exit code to a sane number"); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; $one->reset(); $one->load(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } SKIP: { last SKIP if $] lt "5.008"; $one->reset; my $stderr = ""; { local $INC{'Test/Builder.pm'} = __FILE__; local $Test2::API::VERSION = '0.002'; local $Test::Builder::VERSION = '0.001'; local *STDERR; open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; $one->set_exit; } is($stderr, <<' EOT', "Got warning about version mismatch"); ******************************************************************************** * * * Test::Builder -- Test2::API version mismatch detected * * * ******************************************************************************** Test2::API Version: 0.002 Test::Builder Version: 0.001 This is not a supported configuration, you will have problems. EOT } SKIP: { last SKIP if $] lt "5.008"; require Test2::API::Breakage; no warnings qw/redefine once/; my $ran = 0; local *Test2::API::Breakage::report = sub { $ran++; return "foo" }; use warnings qw/redefine once/; $one->reset(); $one->load(); my $stderr = ""; { local *STDERR; open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; local $? = 255; $one->set_exit; } is($stderr, <<" EOT", "Reported bad modules"); You have loaded versions of test modules known to have problems with Test2. This could explain some test failures. foo EOT } { $one->reset(); $one->load(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->top->set_ipc(undef); ok(!$one->stack->top->ipc, "no IPC"); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } if (CAN_REALLY_FORK) { local $SIG{__WARN__} = sub { }; $one->reset(); my $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); $one->reset(); $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 122; $one->set_exit; is($?, 122, "kept original exit"); } { my $ctx = bless { trace => Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), hub => Test2::Hub->new(), }, 'Test2::API::Context'; $one->contexts->{1234} = $ctx; local $? = 500; my $warnings = warnings { $one->set_exit }; is($?, 255, "set exit code to a sane number"); is_deeply( $warnings, [ "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n" ], "Warned about unfreed context" ); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; delete $INC{'threads.pm'}; ok(!USE_THREADS, "Sanity Check"); $one->reset; ok(!$one->ipc, 'IPC not loaded, no IPC object'); ok($one->finalized, "calling ipc finalized the object"); is($one->ipc_polling, undef, "no polling defined"); ok(!@{$one->ipc_drivers}, "no driver"); if (CAN_THREAD) { local $INC{'threads.pm'} = 1; no warnings 'once'; local *threads::tid = sub { 0 } unless threads->can('tid'); $one->reset; ok($one->ipc, 'IPC loaded if threads are'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } { local $INC{'Test2/IPC.pm'} = 1; $one->reset; ok($one->ipc, 'IPC loaded if Test2::IPC is'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } require Test2::IPC::Driver::Files; $one->reset; $one->add_ipc_driver('Test2::IPC::Driver::Files'); ok($one->ipc, 'IPC loaded if drivers have been added'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') }; like( $warnings->[0], qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "Got warning at correct frame" ); $one->reset; $one->add_ipc_driver('Fake::Fake::XXX'); is( exception { $one->ipc }, "IPC has been requested, but no viable drivers were found. Aborting...\n", "Failed without viable IPC driver" ); } { $one->reset; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, undef"); $one->disable_ipc_polling; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, still undef"); my $cull = 0; no warnings 'once'; local *Fake::Hub::cull = sub { $cull++ }; use warnings; $one->enable_ipc_polling; ok(defined($one->{_pid}), "pid is defined"); ok(defined($one->{_tid}), "tid is defined"); is(@{$one->context_init_callbacks}, 1, "added the callback"); is($one->ipc_polling, 1, "polling on"); $one->set_ipc_shm_last('abc1'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); $cull = 0; $one->disable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "kept the callback"); is($one->ipc_polling, 0, "no polling, set to 0"); $one->set_ipc_shm_last('abc3'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 0, "did not call cull"); $cull = 0; $one->enable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "did not add the callback"); is($one->ipc_polling, 1, "polling on"); $one->set_ipc_shm_last('abc3'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); } { require Test2::IPC::Driver::Files; local $ENV{T2_NO_IPC} = 1; $one->reset; $one->add_ipc_driver('Test2::IPC::Driver::Files'); ok($one->ipc_disabled, "IPC is disabled by env var"); ok(!$one->ipc, 'IPC not loaded'); local $ENV{T2_NO_IPC} = 0; $one->reset; ok(!$one->ipc_disabled, "IPC is not disabled by env var"); ok($one->ipc, 'IPC loaded'); like( exception { $one->ipc_disable }, qr/Attempt to disable IPC after it has been initialized/, "Cannot diable IPC once it is initialized" ); $one->reset; ok(!$one->ipc_disabled, "IPC is not disabled by env var"); $one->ipc_disable; ok($one->ipc_disabled, "IPC is disabled directly"); } done_testing; Test-Simple-1.302125/t/Test2/modules/API/Breakage.t0000644000175000017500000000523313243466361021263 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API::Breakage; my $CLASS = 'Test2::API::Breakage'; for my $meth (qw/upgrade_suggested upgrade_required known_broken/) { my @list = $CLASS->$meth; ok(!(@list % 2), "Got even list ($meth)"); ok(!(grep {!defined($_)} @list), "No undefined items ($meth)"); } { no warnings 'redefine'; local *Test2::API::Breakage::upgrade_suggested = sub { return ('T2Test::UG1' => '1.0', 'T2Test::UG2' => '0.5'); }; local *Test2::API::Breakage::upgrade_required = sub { return ('T2Test::UR1' => '1.0', 'T2Test::UR2' => '0.5'); }; local *Test2::API::Breakage::known_broken = sub { return ('T2Test::KB1' => '1.0', 'T2Test::KB2' => '0.5'); }; use warnings 'redefine'; ok(!$CLASS->report, "Nothing to report"); ok(!$CLASS->report(1), "Still nothing to report"); { local %INC = ( %INC, 'T2Test/UG1.pm' => 1, 'T2Test/UG2.pm' => 1, 'T2Test/UR1.pm' => 1, 'T2Test/UR2.pm' => 1, 'T2Test/KB1.pm' => 1, 'T2Test/KB2.pm' => 1, ); local $T2Test::UG1::VERSION = '0.9'; local $T2Test::UG2::VERSION = '0.9'; local $T2Test::UR1::VERSION = '0.9'; local $T2Test::UR2::VERSION = '0.9'; local $T2Test::KB1::VERSION = '0.9'; local $T2Test::KB2::VERSION = '0.9'; my @report = $CLASS->report; is_deeply( [sort @report], [ sort " * Module 'T2Test::UG1' is outdated, we recommed updating above 1.0.", " * Module 'T2Test::UR1' is outdated and known to be broken, please update to 1.0 or higher.", " * Module 'T2Test::KB1' is known to be broken in version 1.0 and below, newer versions have not been tested. You have: 0.9", " * Module 'T2Test::KB2' is known to be broken in version 0.5 and below, newer versions have not been tested. You have: 0.9", ], "Got expected report items" ); } my %look; unshift @INC => sub { my ($this, $file) = @_; $look{$file}++ if $file =~ m{T2Test}; return; }; ok(!$CLASS->report, "Nothing to report"); is_deeply(\%look, {}, "Did not try to load anything"); ok(!$CLASS->report(1), "Nothing to report"); is_deeply( \%look, { 'T2Test/UG1.pm' => 1, 'T2Test/UG2.pm' => 1, 'T2Test/UR1.pm' => 1, 'T2Test/UR2.pm' => 1, 'T2Test/KB1.pm' => 1, 'T2Test/KB2.pm' => 1, }, "Tried to load modules" ); } done_testing; Test-Simple-1.302125/t/Test2/modules/API/Context.t0000644000175000017500000003052613243466361021211 0ustar exodistexodistuse strict; use warnings; BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } use Test2::Tools::Tiny; use Test2::API qw{ context intercept test2_stack test2_add_callback_context_acquire test2_add_callback_context_init test2_add_callback_context_release }; my $error = exception { context(); 1 }; my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1); like($error, qr/^\Q$exception\E/, "Got the exception" ); my $ref; my $frame; sub wrap(&) { my $ctx = context(); my ($pkg, $file, $line, $sub) = caller(0); $frame = [$pkg, $file, $line, $sub]; $_[0]->($ctx); $ref = "$ctx"; $ctx->release; } wrap { my $ctx = shift; ok($ctx->hub, "got hub"); delete $ctx->trace->frame->[4]; is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); }; wrap { my $ctx = shift; ok("$ctx" ne "$ref", "Got a new context"); my $new = context(); my @caller = caller(0); is_deeply( $new, {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]}, "Additional call to context gets spawn" ); delete $ctx->trace->frame->[4]; is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); $new->release; }; wrap { my $ctx = shift; my $snap = $ctx->snapshot; is_deeply( $snap, {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef}, "snapshot is identical except for canon/spawn/aborted" ); ok($ctx != $snap, "snapshot is a new instance"); }; my $end_ctx; { # Simulate an END block... local *END = sub { local *__ANON__ = 'END'; context() }; my $ctx = END(); $frame = [ __PACKAGE__, __FILE__, __LINE__ - 1, 'main::END' ]; # "__LINE__ - 1" on the preceding line forces the value to be an IV # (even though __LINE__ on its own is a PV), just as (caller)[2] is. $end_ctx = $ctx->snapshot; $ctx->release; } delete $end_ctx->trace->frame->[4]; is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block'); # Test event generation { package My::Formatter; sub write { my $self = shift; my ($e) = @_; push @$self => $e; } } my $events = bless [], 'My::Formatter'; my $hub = Test2::Hub->new( formatter => $events, ); my $trace = Test2::EventFacet::Trace->new( frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); my $e = $ctx->build_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); ok(!@$events, "No events yet"); $e = $ctx->send_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->ok(1, 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->note('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->diag('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->plan(100); is($e->max, 100, "got max"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because'); is($e->name, 'foo', "got name"); is($e->reason, 'because', "got reason"); ok($e->pass, "skip events pass by default"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because', pass => 0); ok(!$e->pass, "can override skip params"); pop @$events; # Test hooks my @hooks; $hub = test2_stack()->top; my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' }); my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' }); test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' }); test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' }); my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire' }); test2_add_callback_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire' }); sub { push @hooks => 'start'; my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' }); push @hooks => 'deep'; my $ctx2 = sub { context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' }); }->(); push @hooks => 'release_deep'; $ctx2->release; push @hooks => 'release_parent'; $ctx->release; push @hooks => 'released_all'; push @hooks => 'new'; $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' }); push @hooks => 'release_new'; $ctx->release; push @hooks => 'done'; }->(); $hub->remove_context_init($ref1); $hub->remove_context_release($ref2); $hub->remove_context_acquire($ref3); @{Test2::API::_context_init_callbacks_ref()} = (); @{Test2::API::_context_release_callbacks_ref()} = (); @{Test2::API::_context_acquire_callbacks_ref()} = (); is_deeply( \@hooks, [qw{ start global_acquire hub_acquire global_init hub_init ctx_init deep global_acquire hub_acquire release_deep release_parent ctx_release_deep ctx_release hub_release global_release released_all new global_acquire hub_acquire global_init hub_init ctx_init2 release_new ctx_release2 hub_release global_release done }], "Got all hook in correct order" ); { my $ctx = context(level => -1); my $one = Test2::API::Context->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), hub => test2_stack()->top, ); is($one->_depth, 0, "default depth"); my $ran = 0; my $doit = sub { is_deeply(\@_, [qw/foo bar/], "got args"); $ran++; die "Make sure old context is restored"; }; eval { $one->do_in_context($doit, 'foo', 'bar') }; my $spawn = context(level => -1, wrapped => -2); is($spawn->trace, $ctx->trace, "Old context restored"); $spawn->release; $ctx->release; ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original") } { like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); my $hub = test2_stack()->top; my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub); is($ctx->{_depth}, 0, "depth set to 0 when not defined."); $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1); is($ctx->{_depth}, 1, "Do not reset depth"); like( exception { $ctx->release }, qr/release\(\) should not be called on context that is neither canon nor a child/, "Non canonical context, do not release" ); } sub { like( exception { my $ctx = context(level => 20) }, qr/Could not find context at depth 21/, "Level sanity" ); ok( !exception { my $ctx = context(level => 20, fudge => 1); $ctx->release; }, "Was able to get context when fudging level" ); }->(); sub { my ($ctx1, $ctx2); sub { $ctx1 = context() }->(); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $ctx2 = context(); $ctx1 = undef; } $ctx2->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/^context\(\) was called to retrieve an existing context, however the existing/, "Got expected warning" ); }->(); sub { my $ctx = context(); my $e = exception { $ctx->throw('xxx') }; like($e, qr/xxx/, "got exception"); $ctx = context(); my $warnings = warnings { $ctx->alert('xxx') }; like($warnings->[0], qr/xxx/, "got warning"); $ctx->release; }->(); sub { my $ctx = context; is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class"); is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class"); like( exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') }, qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/, "Bad event type" ); }->(); { my ($e1, $e2); my $events = intercept { my $ctx = context(); $e1 = $ctx->ok(0, 'foo', ['xxx']); $e2 = $ctx->ok(0, 'foo'); $ctx->release; }; ok($e1->isa('Test2::Event::Ok'), "returned ok event"); ok($e2->isa('Test2::Event::Ok'), "returned ok event"); is($events->[0], $e1, "got ok event 1"); is($events->[3], $e2, "got ok event 2"); is($events->[2]->message, 'xxx', "event 1 diag 2"); ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag"); is($events->[3], $e2, "got ok event 2"); } sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); $ctx2->release; is(0 + $!, 22, "restored the nested \$! in tool"); is($@, 'xyz', "restored the nested \$@ in tool"); is($?, 33, "restored the nested \$? in tool"); }->(); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); # Will not warn since $@ is changed $ctx2 = undef; is(0 + $!, 42, 'Destroy does not reset $!'); is($@, 'app', 'Destroy does not reset $@'); is($?, 43, 'Destroy does not reset $?'); }->(); $ctx->release; is($ctx->errno, 100, "restored errno"); is($ctx->eval_error, 'foobarbaz', "restored eval error"); is($ctx->child_error, 123, "restored child exit"); }->(); sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); # Will not warn since $@ is changed $ctx = undef; is(0 + $!, 22, "Destroy does not restore \$!"); is($@, 'xyz', "Destroy does not restore \$@"); is($?, 33, "Destroy does not restore \$?"); }->(); done_testing; Test-Simple-1.302125/t/Test2/modules/API/Stack.t0000644000175000017500000000350113243466361020623 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API::Stack; use Test2::API qw/test2_ipc/; ok(my $stack = Test2::API::Stack->new, "Create a stack"); ok(!@$stack, "Empty stack"); ok(!$stack->peek, "Nothing to peek at"); ok(!exception { $stack->cull }, "cull lives when stack is empty"); ok(!exception { $stack->all }, "all lives when stack is empty"); ok(!exception { $stack->clear }, "clear lives when stack is empty"); like( exception { $stack->pop(Test2::Hub->new) }, qr/No hubs on the stack/, "No hub to pop" ); my $hub = Test2::Hub->new; ok($stack->push($hub), "pushed a hub"); like( exception { $stack->pop($hub) }, qr/You cannot pop the root hub/, "Root hub cannot be popped" ); $stack->push($hub); like( exception { $stack->pop(Test2::Hub->new) }, qr/Hub stack mismatch, attempted to pop incorrect hub/, "Must specify correct hub to pop" ); is_deeply( [ $stack->all ], [ $hub, $hub ], "Got all hubs" ); ok(!exception { $stack->pop($hub) }, "Popped the correct hub"); is_deeply( [ $stack->all ], [ $hub ], "Got all hubs" ); is($stack->peek, $hub, "got the hub"); is($stack->top, $hub, "got the hub"); $stack->clear; is_deeply( [ $stack->all ], [ ], "no hubs" ); ok(my $top = $stack->top, "Generated a top hub"); is($top->ipc, test2_ipc, "Used sync's ipc"); ok($top->format, 'Got formatter'); is($stack->top, $stack->top, "do not generate a new top if there is already a top"); ok(my $new = $stack->new_hub(), "Add a new hub"); is($stack->top, $new, "new one is on top"); is($new->ipc, $top->ipc, "inherited ipc"); is($new->format, $top->format, "inherited formatter"); my $new2 = $stack->new_hub(formatter => undef, ipc => undef); ok(!$new2->ipc, "built with no ipc"); ok(!$new2->format, "built with no formatter"); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/0000755000175000017500000000000013243466361020042 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Event/TAP/0000755000175000017500000000000013243466361020466 5ustar exodistexodistTest-Simple-1.302125/t/Test2/modules/Event/TAP/Version.t0000644000175000017500000000113713243466361022302 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::Event::TAP::Version'; my $CLASS = 'Test2::Event::TAP::Version'; like( exception { $CLASS->new() }, qr/'version' is a required attribute/, "Must specify the version" ); my $one = $CLASS->new(version => 13); is($one->version, 13, "Got version"); is($one->summary, "TAP version 13", "Got summary"); is_deeply( $one->facet_data, { about => { package => $CLASS, details => "TAP version 13"}, info => [{tag => 'INFO', debug => 0, details => "TAP version 13"}], }, "Got facet data" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Exception.t0000644000175000017500000000232213243466361022164 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Exception; my $exception = Test2::Event::Exception->new( trace => {frame => []}, error => "evil at lake_of_fire.t line 6\n", ); ok($exception->causes_fail, "Exception events always cause failure"); is($exception->summary, "Exception: evil at lake_of_fire.t line 6", "Got summary"); ok($exception->diagnostics, "Exception events are counted as diagnostics"); my $facet_data = $exception->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{errors}, [{ tag => 'ERROR', fail => 1, details => "evil at lake_of_fire.t line 6\n", }], "Got error facet", ); my $hash = {an => 'error'}; my $str = "$hash"; $exception = Test2::Event::Exception->new( trace => {frame => []}, error => $hash, ); ok($exception->causes_fail, "Exception events always cause failure"); is($exception->error, $str, "Got stringified exception"); $facet_data = $exception->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{errors}, [{ tag => 'ERROR', fail => 1, details => $str, }], "Got error facet", ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Encoding.t0000644000175000017500000000112013243466361021747 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::Event::Encoding'; my $CLASS = 'Test2::Event::Encoding'; like( exception { $CLASS->new() }, qr/'encoding' is a required attribute/, "Must specify the encoding" ); my $one = $CLASS->new(encoding => 'utf8'); is($one->encoding, 'utf8', "Got encoding"); is($one->summary, "Encoding set to utf8", "Got summary"); is_deeply( $one->facet_data, { about => { package => $CLASS, details => "Encoding set to utf8" }, control => { encoding => 'utf8' }, }, "Got facet data" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Waiting.t0000644000175000017500000000116613243466361021635 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Waiting; my $waiting = Test2::Event::Waiting->new( trace => {}, ); ok($waiting, "Created event"); ok($waiting->global, "waiting is global"); is($waiting->summary, "IPC is waiting for children to finish...", "Got summary"); my $facet_data = $waiting->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{info}, [ { tag => 'INFO', debug => 0, details => "IPC is waiting for children to finish...", }, ], "Got added info facet" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Subtest.t0000644000175000017500000000261713243466361021666 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Subtest; my $st = 'Test2::Event::Subtest'; my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); my $one = $st->new( trace => $trace, pass => 1, buffered => 1, name => 'foo', subtest_id => "1-1-1", ); ok($one->isa('Test2::Event::Ok'), "Inherit from Ok"); is_deeply($one->subevents, [], "subevents is an arrayref"); is($one->summary, "foo", "simple summary"); $one->set_todo(''); is($one->summary, "foo (TODO)", "simple summary + TODO"); $one->set_todo('foo'); is($one->summary, "foo (TODO: foo)", "simple summary + TODO + Reason"); $one->set_todo(undef); $one->set_name(''); is($one->summary, "Nameless Subtest", "unnamed summary"); require Test2::Event::Pass; push @{$one->subevents} => Test2::Event::Pass->new(name => 'xxx'); my $facet_data = $one->facet_data; ok($facet_data->{about}, "got parent facet data"); is_deeply( $facet_data->{parent}, { hid => "1-1-1", buffered => 1, children => [ { about => { details => 'pass', package => 'Test2::Event::Pass' }, assert => { details => 'xxx', pass => 1 }, } ], }, "Got facet data" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Generic.t0000644000175000017500000000633713243466361021614 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; use Test2::API qw/context intercept/; sub tool { my $ctx = context(); my $e = $ctx->send_event('Generic', @_); $ctx->release; return $e; } my $e; intercept { $e = tool() }; ok($e, "got event"); ok($e->isa('Test2::Event'), "It is an event"); ok($e->isa('Test2::Event::Generic'), "It is an event"); delete $e->{trace}; is_deeply( $e, { causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, }, "Defaults" ); for my $f (qw/causes_fail increments_count diagnostics no_display/) { is($e->$f, 0, "'$f' is 0"); is_deeply([$e->$f], [0], "'$f' is 0 is list context as well"); my $set = "set_$f"; $e->$set(1); is($e->$f, 1, "'$f' was set to 1"); } for my $f (qw/callback terminate global sets_plan/) { is($e->$f, undef, "no $f"); is_deeply([$e->$f], [], "$f is empty in list context"); } like($e->summary, qr/Test2::Event::Generic/, "Got base class summary"); like( exception { $e->set_sets_plan('bad') }, qr/'sets_plan' must be an array reference/, "Must provide an arrayref" ); $e->set_sets_plan([0, skip => 'cause']); is_deeply([$e->sets_plan], [0, skip => 'cause'], "sets_plan returns a list, not a ref"); $e->set_sets_plan(undef); ok(!exists $e->{sets_plan}, "Removed sets_plan key"); ok(!$e->sets_plan, "sets_plan is cleared"); $e->set_global(0); is($e->global, 0, "global is off"); $e->set_global(1); is($e->global, 1, "global is on"); $e->set_global(0); is($e->global, 0, "global is again"); $e->set_global(undef); ok(!exists $e->{global}, "removed global key"); is($e->global, undef, "global is not defined"); like( exception { $e->set_callback('dogfood') }, qr/callback must be a code reference/, "Callback must be code" ); my $ran = 0; $e->set_callback(sub { $ran++; my $self = shift; is($self, $e, "got self"); is_deeply( \@_, ['a', 'b', 'c'], "Got args" ); return 'foo'; }); is($e->callback('a', 'b', 'c'), 'foo', "got callback's return"); ok($ran, "ran callback"); $e->set_callback(undef); ok(!$e->callback, "no callback"); ok(!exists $e->{callback}, "no callback key"); like( exception { $e->set_terminate('1.1') }, qr/terminate must be a positive integer/, "terminate only takes integers" ); like( exception { $e->set_terminate('foo') }, qr/terminate must be a positive integer/, "terminate only takes numbers" ); like( exception { $e->set_terminate('-1') }, qr/terminate must be a positive integer/, "terminate only takes positive integers" ); $e->set_terminate(0), is($e->terminate, 0, "set to 0, 0 is valid"); $e->set_terminate(1), is($e->terminate, 1, "set to 1"); $e->set_terminate(123), is($e->terminate, 123, "set to 123"); $e->set_terminate(0), is($e->terminate, 0, "set to 0, 0 is valid"); $e->set_terminate(undef); is($e->terminate, undef, "terminate is not defined"); ok(!exists $e->{terminate}, "no terminate key"); # Test constructor args intercept { $e = tool(causes_fail => 1, increments_count => 'a') }; is($e->causes_fail, 1, "attr from constructor"); is($e->increments_count, 'a', "attr from constructor"); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Plan.t0000644000175000017500000001052613243466361021125 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Plan; use Test2::EventFacet::Trace; my $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); is($plan->summary, "Plan is 100 assertions", "simple summary"); is_deeply( [$plan->sets_plan], [100, '', undef], "Got plan details"); ok(!$plan->global, "regular plan is not a global event"); is($plan->terminate, undef, "No terminate for normal plan"); $plan->set_max(0); $plan->set_directive('SKIP'); $plan->set_reason('foo'); is($plan->terminate, 0, "Terminate 0 on skip_all"); is($plan->summary, "Plan is 'SKIP', foo", "skip summary"); is_deeply( [$plan->sets_plan], [0, 'SKIP', 'foo'], "Got skip details"); $plan->set_max(0); $plan->set_directive('NO PLAN'); $plan->set_reason(undef); is($plan->summary, "Plan is 'NO PLAN'", "NO PLAN summary"); is_deeply( [$plan->sets_plan], [0, 'NO PLAN', undef], "Got 'NO PLAN' details"); is($plan->terminate, undef, "No terminate for no_plan"); $plan->set_max(100); $plan->set_directive(undef); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'skip_all', ); is($plan->directive, 'SKIP', "Change skip_all to SKIP"); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'no_plan', ); is($plan->directive, 'NO PLAN', "Change no_plan to 'NO PLAN'"); ok(!$plan->global, "NO PLAN is not global"); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'foo', ); }, qr/'foo' is not a valid plan directive/, "Invalid Directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, reason => 'foo', ); }, qr/Cannot have a reason without a directive!/, "Reason without directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), ); }, qr/No number of tests specified/, "Nothing to do" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 'skip', ); }, qr/Plan test count 'skip' does not appear to be a valid positive integer/, "Max must be an integer" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); my $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, undef, "no termination defined"); is_deeply( $facet_data->{plan}, {count => 100}, "Set the count" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'NO PLAN', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, undef, "no termination defined"); is_deeply( $facet_data->{plan}, {count => 0, none => 1}, "No plan" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'SKIP', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, 0, "terminate with 0"); is_deeply( $facet_data->{plan}, {count => 0, skip => 1}, "Skip, no reason" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'SKIP', reason => 'because', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, 0, "terminate with 0"); is_deeply( $facet_data->{plan}, {count => 0, skip => 1, details => 'because'}, "Skip, no reason" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Note.t0000644000175000017500000000236213243466361021137 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Note; use Test2::EventFacet::Trace; my $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($note->summary, 'foo', "summary is just message"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($note->message, 'undef', "set undef message to undef"); is($note->summary, 'undef', "summary is just message even when undef"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($note->message, qr/^HASH\(.*\)$/, "stringified the input value"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'Hi there', ); my $facet_data = $note->facet_data; ok($facet_data->{about}, "Got 'about' from common"); ok($facet_data->{trace}, "Got 'trace' from common"); is_deeply( $facet_data->{info}, [{ tag => 'NOTE', debug => 0, details => 'Hi there', }], "Got info facet" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Pass.t0000644000175000017500000000224713243466361021142 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use ok 'Test2::Event::Pass'; my $CLASS = 'Test2::Event::Pass'; my $one = $CLASS->new(name => 'soup for you', trace => {frame => ['foo', 'foo.pl', 42]}); is($one->summary, "pass", 'summary'); is($one->increments_count, 1, 'increments_count'); is($one->diagnostics, 0, 'diagnostics'); is($one->no_display, 0, 'no_display'); is($one->subtest_id, undef, 'subtest_id'); is($one->terminate, undef, 'terminate'); is($one->global, undef, 'global'); is($one->sets_plan, undef, 'sets_plan'); is($one->causes_fail, 0, 'causes_fail is false'); $one->add_amnesty({tag => 'blah', details => 'blah'}); $one->add_info({tag => 'xxx', details => 'yyy'}); is_deeply( $one->facet_data, { trace => {frame => ['foo', 'foo.pl', 42]}, about => {package => $CLASS, details => 'pass'}, assert => {pass => 1, details => 'soup for you'}, amnesty => [{tag => 'blah', details => 'blah'}], info => [{tag => 'xxx', details => 'yyy'}], }, "Got facet data" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Bail.t0000644000175000017500000000316113243466361021077 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Bail; use Test2::EventFacet::Trace; my $bail = Test2::Event::Bail->new( trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42]), reason => 'evil', ); ok($bail->causes_fail, "bailout always causes fail."); is($bail->terminate, 255, "Bail will cause the test to exit."); is($bail->global, 1, "Bail is global, everything should bail"); is($bail->summary, "Bail out! evil", "Summary includes reason"); $bail->set_reason(""); is($bail->summary, "Bail out!", "Summary has no reason"); ok($bail->diagnostics, "Bail events are counted as diagnostics"); is_deeply( $bail->facet_data, { about => { package => 'Test2::Event::Bail', }, control => { global => 1, terminate => 255, details => '', halt => 1 }, trace => { frame => [ 'foo', 'foo.t', '42', ], pid => $$, tid => 0 }, }, "Got facet data", ); $bail->set_reason('uhg'); is_deeply( $bail->facet_data, { about => { package => 'Test2::Event::Bail', }, control => { global => 1, terminate => 255, details => 'uhg', halt => 1 }, trace => { frame => [ 'foo', 'foo.t', '42', ], pid => $$, tid => 0 }, }, "Got facet data with reason", ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Skip.t0000644000175000017500000000163613243466361021143 0ustar exodistexodistuse Test2::Tools::Tiny; use strict; use warnings; use Test2::Event::Skip; use Test2::EventFacet::Trace; my $skip = Test2::Event::Skip->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), name => 'skip me', reason => 'foo', ); my $facet_data = $skip->facet_data; ok($facet_data->{about}, "Got basic data"); is_deeply( $facet_data->{amnesty}, [ { tag => 'skip', details => 'foo', inherited => 0, } ], "Added some amnesty for the skip", ); is($skip->name, 'skip me', "set name"); is($skip->reason, 'foo', "got skip reason"); ok(!$skip->pass, "no default for pass"); ok($skip->effective_pass, "TODO always effectively passes"); is($skip->summary, "skip me (SKIP: foo)", "summary with reason"); $skip->set_reason(''); is($skip->summary, "skip me (SKIP)", "summary without reason"); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Fail.t0000644000175000017500000000221613243466361021103 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use ok 'Test2::Event::Fail'; my $CLASS = 'Test2::Event::Fail'; my $one = $CLASS->new(name => 'no soup for you'); is($one->summary, "fail", 'summary'); is($one->increments_count, 1, 'increments_count'); is($one->diagnostics, 0, 'diagnostics'); is($one->no_display, 0, 'no_display'); is($one->subtest_id, undef, 'subtest_id'); is($one->terminate, undef, 'terminate'); is($one->global, undef, 'global'); is($one->sets_plan, undef, 'sets_plan'); is($one->causes_fail, 1, 'causes_fail'); $one->add_amnesty({tag => 'blah', details => 'blah'}); is($one->causes_fail, 0, 'causes_fail is off with amnesty'); $one->add_info({tag => 'xxx', details => 'yyy'}); is_deeply( $one->facet_data, { about => {package => $CLASS, details => 'fail'}, assert => {pass => 0, details => 'no soup for you'}, amnesty => [{tag => 'blah', details => 'blah'}], info => [{tag => 'xxx', details => 'yyy'}], }, "Got facet data" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Diag.t0000644000175000017500000000246313243466361021100 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Diag; use Test2::EventFacet::Trace; my $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($diag->summary, 'foo', "summary is just message"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($diag->message, 'undef', "set undef message to undef"); is($diag->summary, 'undef', "summary is just message even when undef"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value"); ok($diag->diagnostics, "Diag events are counted as diagnostics"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => "Hi there", ); my $facet_data = $diag->facet_data; ok($facet_data->{about}, "Got 'about' from common"); ok($facet_data->{trace}, "Got 'trace' from common"); is_deeply( $facet_data->{info}, [{ tag => 'DIAG', debug => 1, details => 'Hi there', }], "Got info facet" ); done_testing; Test-Simple-1.302125/t/Test2/modules/Event/Ok.t0000644000175000017500000001053513243466361020604 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; use Test2::Event::Ok; use Test2::Event::Diag; use Test2::API qw/context/; my $trace; sub before_each { # Make sure there is a fresh trace object for each group $trace = Test2::EventFacet::Trace->new( frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], ); } tests Passing => sub { my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, name => 'the_test', ); ok($ok->increments_count, "Bumps the count"); ok(!$ok->causes_fail, "Passing 'OK' event does not cause failure"); is($ok->pass, 1, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 1, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 1, details => 'the_test', }, "Got assert facet", ); $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, name => '', ); is($ok->summary, "Nameless Assertion", "Nameless test"); $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 1, details => '', }, "Got assert facet", ); }; tests Failing => sub { local $ENV{HARNESS_ACTIVE} = 1; local $ENV{HARNESS_IS_VERBOSE} = 1; my $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test', ); ok($ok->increments_count, "Bumps the count"); ok($ok->causes_fail, "A failing test causes failures"); is($ok->pass, 0, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 0, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test', }, "Got assert facet", ); }; tests "Failing TODO" => sub { local $ENV{HARNESS_ACTIVE} = 1; local $ENV{HARNESS_IS_VERBOSE} = 1; my $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test', todo => 'A Todo', ); ok($ok->increments_count, "Bumps the count"); is($ok->pass, 0, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 1, "effective pass is true from todo"); is($ok->summary, "the_test (TODO: A Todo)", "Summary is just the name of the test + todo"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test', }, "Got assert facet", ); is_deeply( $facet_data->{amnesty}, [{ tag => 'TODO', details => 'A Todo', }], "Got amnesty facet", ); $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test2', todo => '', ); ok($ok->effective_pass, "empty string todo is still a todo"); is($ok->summary, "the_test2 (TODO)", "Summary is just the name of the test + todo"); $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test2', }, "Got assert facet", ); is_deeply( $facet_data->{amnesty}, [{ tag => 'TODO', details => '', }], "Got amnesty facet", ); }; tests init => sub { my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, ); is($ok->effective_pass, 1, "set effective pass"); }; done_testing; Test-Simple-1.302125/t/Test2/modules/Event.t0000644000175000017500000004254013243466361020234 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event(); use Test2::EventFacet::Trace(); use Test2::Event::Generic; use Scalar::Util qw/reftype/; tests old_api => sub { { package My::MockEvent; use base 'Test2::Event'; use Test2::Util::HashBase qw/foo bar baz/; } ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; my $one = My::MockEvent->new(trace => 'fake'); ok(!$one->causes_fail, "Events do not cause failures by default"); ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); $one->set_meta('xxx', '123'); is($one->meta('xxx'), '123', "got meta-data"); is($one->meta('xxx', '321'), '123', "did not use default"); is($one->meta('yyy', '1221'), '1221', "got the default"); is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); is($one->summary, 'My::MockEvent', "Default summary is event package"); is($one->diagnostics, 0, "Not diagnostics by default"); }; tests deprecated => sub { my $e = Test2::Event->new(trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.pl', 42], nested => 2, hid => 'maybe')); my $warnings = warnings { local $ENV{AUTHOR_TESTING} = 1; is($e->nested, 2, "Got nested from the trace"); is($e->in_subtest, 'maybe', "got hid from trace"); $e->trace->{nested} = 0; local $ENV{AUTHOR_TESTING} = 0; is($e->nested, 0, "Not nested"); is($e->in_subtest, undef, "Did not get hid"); }; is(@$warnings, 2, "got warnings once each"); like($warnings->[0], qr/Use of Test2::Event->nested\(\) is deprecated/, "Warned about deprecation"); like($warnings->[1], qr/Use of Test2::Event->in_subtest\(\) is deprecated/, "Warned about deprecation"); }; tests facet_data => sub { my $e = Test2::Event::Generic->new( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, callback => undef, terminate => undef, global => undef, sets_plan => undef, summary => undef, facet_data => undef, ); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, }, "Facet data has control with onyl false values, and an about" ); $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, }, "Got a trace now" ); $e->set_causes_fail(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, errors => [ { tag => 'FAIL', details => 'Test2::Event::Generic', fail => 1, } ], }, "Got an error" ); $e->set_increments_count(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 0, details => 'Test2::Event::Generic', }, }, "Got an assert now" ); $e->set_causes_fail(0); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, }, "Got a passing assert now" ); $e->set_global(1); $e->set_terminate(255); $e->set_callback(sub {1}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, }, "control fields were altered" ); my $data; { no warnings 'once'; local *Test2::Event::Generic::subtest_id = sub { 123 }; $data = $e->facet_data; } is_deeply( $data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, parent => {hid => 123}, }, "Added parent" ); $e->set_meta('foo', {a => 1}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, }, "Grabbed meta" ); $e->set_sets_plan([5]); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 5 }, }, "Plan facet added" ); $e->set_terminate(undef); $e->set_sets_plan([0, SKIP => 'because']); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => 0, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, skip => 1, details => 'because' }, }, "Plan set terminate, skip, and details" ); $e->set_sets_plan([0, 'NO PLAN' => 'because']); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, none => 1, details => 'because' }, }, "Plan does not set terminate, but sets 'none' and 'details'" ); $e->add_amnesty({tag => 'foo', details => 'bar'}); $e->add_amnesty({tag => 'baz', details => 'bat'}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, none => 1, details => 'because' }, amnesty => [ { tag => 'foo', details => 'bar' }, { tag => 'baz', details => 'bat' }, ], }, "Amnesty added" ); $e = Test2::Event::Generic->new(); $e->set_diagnostics(1); $e->set_no_display(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => 1, }, control => { has_callback => 0, terminate => undef, global => 0, }, }, "No Info" ); $e->set_no_display(0); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0, }, info => [{ details => 'Test2::Event::Generic', tag => 'DIAG', debug => 1, }], }, "Got debug Info" ); $e->set_summary("foo bar baz"); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'foo bar baz', no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0, }, info => [{ details => 'foo bar baz', tag => 'DIAG', debug => 1, }], }, "Got debug Info with summary change" ); }; tests facets => sub { my $data = { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => {count => 0, none => 1, details => 'because'}, parent => {hid => 123, children => []}, amnesty => [ {tag => 'foo', details => 'bar'}, {tag => 'baz', details => 'bat'}, ], info => [ { details => 'foo bar baz', tag => 'DIAG', debug => 1, } ], errors => [{ tag => 'FAIL', details => 'Test2::Event::Generic', fail => 1, }], }; my $e = Test2::Event::Generic->new(facet_data => $data); is_deeply( $e->facet_data, $e->facets, "Facets and facet_data have the same structure" ); my $facets = $e->facets; for my $key (sort keys %$facets) { my $type = "Test2::EventFacet::" . ucfirst($key); $type =~ s/s$//; my $val = $facets->{$key}; if ($type->is_list) { for my $f (@$val) { ok($f->isa('Test2::EventFacet'), "'$key' has a blessed facet"); ok($f->isa("$type"), "'$key' is a '$type'") or diag("$f"); } } else { ok($val->isa('Test2::EventFacet'), "'$key' has a blessed facet"); ok($val->isa($type), "'$key' is a '$type'"); } } }; tests common_facet_data => sub { my $e = Test2::Event::Generic->new( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, callback => undef, terminate => undef, global => undef, sets_plan => undef, summary => undef, facet_data => undef, ); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', }, }, "Facet data has an about" ); $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, }, "Got a trace now" ); $e->set_meta('foo', {a => 1}); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, meta => {foo => {a => 1}}, }, "Grabbed meta" ); $e->add_amnesty({tag => 'foo', details => 'bar'}); $e->add_amnesty({tag => 'baz', details => 'bat'}); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, meta => {foo => {a => 1}}, amnesty => [ {tag => 'foo', details => 'bar'}, {tag => 'baz', details => 'bat'}, ], }, "Amnesty added" ); }; done_testing; Test-Simple-1.302125/t/Test2/modules/Util.t0000644000175000017500000000373413243466361020072 0ustar exodistexodistuse strict; use warnings; use Config qw/%Config/; use Test2::Tools::Tiny; use Test2::Util qw/ try get_tid USE_THREADS pkg_to_file CAN_FORK CAN_THREAD CAN_REALLY_FORK CAN_SIGSYS IS_WIN32 clone_io /; BEGIN { if ($] lt "5.008") { require Test::Builder::IO::Scalar; } } { for my $try (\&try, Test2::Util->can('_manual_try'), Test2::Util->can('_local_try')) { my ($ok, $err) = $try->(sub { die "xxx" }); ok(!$ok, "cought exception"); like($err, qr/xxx/, "expected exception"); ($ok, $err) = $try->(sub { 0 }); ok($ok, "Success"); ok(!$err, "no error"); } } is(pkg_to_file('A::Package::Name'), 'A/Package/Name.pm', "Converted package to file"); # Make sure running them does not die # We cannot really do much to test these. CAN_THREAD(); CAN_FORK(); CAN_REALLY_FORK(); IS_WIN32(); is(IS_WIN32(), ($^O eq 'MSWin32') ? 1 : 0, "IS_WIN32 is correct ($^O)"); my %sigs = map {$_ => 1} split /\s+/, $Config{sig_name}; if ($sigs{SYS}) { ok(CAN_SIGSYS, "System has SIGSYS"); } else { ok(!CAN_SIGSYS, "System lacks SIGSYS"); } my $check_for_sig_sys = Test2::Util->can('_check_for_sig_sys'); ok($check_for_sig_sys->("FOO SYS BAR"), "Found SIGSYS in the middle"); ok($check_for_sig_sys->("SYS FOO BAR"), "Found SIGSYS at start"); ok($check_for_sig_sys->("FOO BAR SYS"), "Found SIGSYS at end"); ok(!$check_for_sig_sys->("FOO SYSX BAR"), "SYSX is not SYS"); ok(!$check_for_sig_sys->("FOO XSYS BAR"), "XSYS is not SYS"); my $io = clone_io(\*STDOUT); ok($io, "Cloned the filehandle"); close($io); my $fh; my $out = ''; if ($] ge "5.008") { open($fh, '>', \$out) or die "Could not open filehandle"; } else { $fh = Test::Builder::IO::Scalar->new(\$out) or die "Could not open filehandle"; } $io = clone_io($fh); is($io, $fh, "For a scalar handle we simply return the original handle, no other choice"); print $io "Test\n"; is($out, "Test\n", "wrote to the scalar handle"); done_testing; Test-Simple-1.302125/t/Test2/modules/IPC.t0000644000175000017500000000064613243466361017567 0ustar exodistexodistuse strict; use warnings; use Test2::IPC qw/cull/; use Test2::API qw/context test2_ipc_drivers test2_ipc intercept/; use Test2::Tools::Tiny; test2_ipc(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Default driver" ); ok(__PACKAGE__->can('cull'), "Imported cull"); ok(eval { intercept { Test2::IPC->import }; 1 }, "Can re-import Test2::IPC without error") or diag $@; done_testing; Test-Simple-1.302125/t/Test2/modules/Hub.t0000644000175000017500000002724013243466361017671 0ustar exodistexodistuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context test2_ipc_drivers/; use Test2::Util qw/CAN_FORK CAN_THREAD CAN_REALLY_FORK/; { package My::Formatter; sub new { bless [], shift }; my $check = 1; sub write { my $self = shift; my ($e, $count) = @_; push @$self => $e; } } { package My::Event; use base 'Test2::Event'; use Test2::Util::HashBase qw{msg}; } tests basic => sub { my $hub = Test2::Hub->new( formatter => My::Formatter->new, ); my $send_event = sub { my ($msg) = @_; my $e = My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); $hub->send($e); }; ok(my $e1 = $send_event->('foo'), "Created event"); ok(my $e2 = $send_event->('bar'), "Created event"); ok(my $e3 = $send_event->('baz'), "Created event"); my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is_deeply( $old, [$e1, $e2, $e3], "Formatter got all events" ); }; tests follow_ups => sub { my $hub = Test2::Hub->new; $hub->set_count(1); my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__], ); my $ran = 0; $hub->follow_up(sub { my ($d, $h) = @_; is_deeply($d, $trace, "Got trace"); is_deeply($h, $hub, "Got hub"); ok(!$hub->ended, "Hub state has not ended yet"); $ran++; }); like( exception { $hub->follow_up('xxx') }, qr/follow_up only takes coderefs for arguments, got 'xxx'/, "follow_up takes a coderef" ); $hub->finalize($trace); is($ran, 1, "ran once"); is_deeply( $hub->ended, $trace->frame, "Ended at the expected place." ); eval { $hub->finalize($trace) }; is($ran, 1, "ran once"); $hub = undef; }; tests IPC => sub { my ($driver) = test2_ipc_drivers(); is($driver, 'Test2::IPC::Driver::Files', "Default Driver"); my $ipc = $driver->new; my $hub = Test2::Hub->new( formatter => My::Formatter->new, ipc => $ipc, ); my $build_event = sub { my ($msg) = @_; return My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); }; my $e1 = $build_event->('foo'); my $e2 = $build_event->('bar'); my $e3 = $build_event->('baz'); my $do_send = sub { $hub->send($e1); $hub->send($e2); $hub->send($e3); }; my $do_check = sub { my $name = shift; my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is_deeply( $old, [$e1, $e2, $e3], "Formatter got all events ($name)" ); }; if (CAN_REALLY_FORK) { my $pid = fork(); die "Could not fork!" unless defined $pid; if ($pid) { is(waitpid($pid, 0), $pid, "waited properly"); ok(!$?, "child exited with success"); $hub->cull(); $do_check->('Fork'); } else { $do_send->(); exit 0; } } if (CAN_THREAD && $] ge '5.010') { require threads; my $thr = threads->new(sub { $do_send->() }); $thr->join; $hub->cull(); $do_check->('Threads'); } $do_send->(); $hub->cull(); $do_check->('no IPC'); }; tests listen => sub { my $hub = Test2::Hub->new(); my @events; my @counts; my $it = $hub->listen(sub { my ($h, $e, $count) = @_; is_deeply($h, $hub, "got hub"); push @events => $e; push @counts => $count; }); my $second; my $it2 = $hub->listen(sub { $second++ }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unlisten($it); $hub->send($ok3); is_deeply(\@counts, [1, 2], "Got counts"); is_deeply(\@events, [$ok1, $ok2], "got events"); is($second, 3, "got all events in listener that was not removed"); like( exception { $hub->listen('xxx') }, qr/listen only takes coderefs for arguments, got 'xxx'/, "listen takes a coderef" ); }; tests metadata => sub { my $hub = Test2::Hub->new(); my $default = { foo => 1 }; my $meta = $hub->meta('Foo', $default); is_deeply($meta, $default, "Set Meta"); $meta = $hub->meta('Foo', {}); is_deeply($meta, $default, "Same Meta"); $hub->delete_meta('Foo'); is($hub->meta('Foo'), undef, "No Meta"); $hub->meta('Foo', {})->{xxx} = 1; is($hub->meta('Foo')->{xxx}, 1, "Vivified meta and set it"); like( exception { $hub->meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); like( exception { $hub->delete_meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->delete_meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); }; tests filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->filter('xxx') }, qr/filter only takes coderefs for arguments, got 'xxx'/, "filter takes a coderef" ); }; tests pre_filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->pre_filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->pre_filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->pre_unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other pre_filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->pre_filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->pre_filter('xxx') }, qr/pre_filter only takes coderefs for arguments, got 'xxx'/, "pre_filter takes a coderef" ); }; tests state => sub { my $hub = Test2::Hub->new; is($hub->count, 0, "count starts at 0"); is($hub->failed, 0, "failed starts at 0"); is($hub->is_passing, 1, "start off passing"); is($hub->plan, undef, "no plan yet"); $hub->is_passing(0); is($hub->is_passing, 0, "Can Fail"); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_count(1); is($hub->count, 1, "Added a passing result"); is($hub->failed, 0, "still no fails"); is($hub->is_passing, 1, "Still passing"); $hub->set_count(2); $hub->set_failed(1); is($hub->count, 2, "Added a result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); $hub->is_passing(1); is($hub->is_passing, 0, "is_passing always false after a failure"); $hub->set_failed(0); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_failed(1); is($hub->count, 2, "No new result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); ok(!eval { $hub->plan('foo'); 1 }, "Could not set plan to 'foo'"); like($@, qr/'foo' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'/, "Got expected error"); ok($hub->plan(5), "Can set plan to integer"); is($hub->plan, 5, "Set the plan to an integer"); $hub->set__plan(undef); ok($hub->plan('NO PLAN'), "Can set plan to 'NO PLAN'"); is($hub->plan, 'NO PLAN', "Set the plan to 'NO PLAN'"); $hub->set__plan(undef); ok($hub->plan('SKIP'), "Can set plan to 'SKIP'"); is($hub->plan, 'SKIP', "Set the plan to 'SKIP'"); ok(!eval { $hub->plan(5); 1 }, "Cannot change plan"); like($@, qr/You cannot change the plan/, "Got error"); my $trace = Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); $hub->finalize($trace); my $ok = eval { $hub->finalize($trace) }; my $err = $@; ok(!$ok, "died"); is($err, <<" EOT", "Got expected error"); Test already ended! First End: foo.t line 42 Second End: foo.t line 42 EOT $hub = Test2::Hub->new; $hub->plan(5); $hub->set_count(5); $hub->set_failed(1); $hub->set_ended($trace); $hub->set_bailed_out("foo"); $hub->set_skip_reason('xxx'); ok(!$hub->is_passing, "not passing"); $hub->reset_state; ok(!$hub->plan, "no plan"); is($hub->count, 0, "count reset to 0"); is($hub->failed, 0, "reset failures"); ok(!$hub->ended, "not ended"); ok(!$hub->bailed_out, "did not bail out"); ok(!$hub->skip_reason, "no skip reason"); }; done_testing; Test-Simple-1.302125/t/Test2/modules/API.t0000644000175000017500000002126013243466361017560 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; my ($LOADED, $INIT); BEGIN { $INIT = Test2::API::test2_init_done; $LOADED = Test2::API::test2_load_done; }; use Test2::IPC; use Test2::Tools::Tiny; use Test2::Util qw/get_tid/; my $CLASS = 'Test2::API'; # Ensure we do not break backcompat later by removing anything ok(Test2::API->can($_), "$_ method is present") for qw{ context_do no_context test2_init_done test2_load_done test2_pid test2_tid test2_stack test2_no_wait test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_ipc test2_ipc_disable test2_ipc_disabled test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_formatter test2_formatters test2_formatter_add test2_formatter_set }; ok(!$LOADED, "Was not load_done right away"); ok(!$INIT, "Init was not done right away"); ok(Test2::API::test2_load_done, "We loaded it"); # Note: This is a check that stuff happens in an END block. { { package FOLLOW; sub DESTROY { return if $_[0]->{fixed}; print "not ok - Did not run end ($_[0]->{name})!"; $? = 255; exit 255; } } our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW'; Test2::API::test2_add_callback_exit( sub { print "# Running END hook\n"; $kill1->{fixed} = 1; } ); our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW'; my $old = Test2::API::Instance->can('set_exit'); no warnings 'redefine'; *Test2::API::Instance::set_exit = sub { $kill2->{fixed} = 1; print "# Running set_exit\n"; $old->(@_); }; } ok($CLASS->can('test2_init_done')->(), "init is done."); ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading"); is($CLASS->can('test2_pid')->(), $$, "got pid"); is($CLASS->can('test2_tid')->(), get_tid(), "got tid"); ok($CLASS->can('test2_stack')->(), 'got stack'); is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack"); ok($CLASS->can('test2_ipc')->(), 'got ipc'); is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC"); is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list"); # Verify it reports to the correct file/line, there was some trouble with this... my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') }; my $sub1 = sub { like( $warnings->[0], qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "got warning about adding driver too late" ); }; if ($] le "5.006002") { todo("TODO known to fail on $]", $sub1); } else { $sub1->(); } is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list"); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); $CLASS->can('test2_ipc_disable_polling')->(); ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off"); $CLASS->can('test2_ipc_enable_polling')->(); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); ok($CLASS->can('test2_formatter')->(), "Got a formatter"); is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)"); my $ran = 0; $CLASS->can('test2_add_callback_post_load')->(sub { $ran++ }); is($ran, 1, "ran the post-load"); like( exception { $CLASS->can('test2_formatter_set')->() }, qr/No formatter specified/, "formatter_set requires an argument" ); like( exception { $CLASS->can('test2_formatter_set')->('fake') }, qr/Global Formatter already set/, "formatter_set doesn't work after initialization", ); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); $CLASS->can('test2_no_wait')->(1); ok($CLASS->can('test2_no_wait')->(), "no_wait is set"); $CLASS->can('test2_no_wait')->(undef); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); $CLASS->can('test2_ipc_wait_disable')->(); ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled"); $CLASS->can('test2_ipc_wait_enable')->(); ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); my $pctx; sub tool_a($;$) { Test2::API::context_do { my $ctx = shift; my ($bool, $name) = @_; $pctx = wantarray; die "xyz" unless $bool; $ctx->ok($bool, $name); return unless defined $pctx; return (1, 2) if $pctx; return 'a'; } @_; } $pctx = 'x'; tool_a(1, "void context test"); ok(!defined($pctx), "void context"); my $x = tool_a(1, "scalar context test"); ok(defined($pctx) && $pctx == 0, "scalar context"); is($x, 'a', "got scalar return"); my @x = tool_a(1, "array context test"); ok($pctx, "array context"); is_deeply(\@x, [1, 2], "Got array return"); like( exception { tool_a(0) }, qr/^xyz/, "got exception" ); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context()"); $inner->release; }; $middle->release; }->(); $outer->release; }->(); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); $inner->release; } $outer->hub->hid; $middle->release; }->(); $outer->release; }->(); sub { my @warnings; my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); local $SIG{__WARN__} = sub { push @warnings => @_ }; Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); } $outer->hub->hid; $middle->release; }->(); $outer->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "Got warning about unreleased context" ); }->(); sub { my $hub = Test2::Hub->new(); my $ctx = context(hub => $hub); is($ctx->hub,$hub, 'got the hub of context() argument'); $ctx->release; }->(); my $sub = sub { }; Test2::API::test2_add_callback_context_acquire($sub); Test2::API::test2_add_callback_context_init($sub); Test2::API::test2_add_callback_context_release($sub); Test2::API::test2_add_callback_exit($sub); Test2::API::test2_add_callback_post_load($sub); is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 1, "got the one instance of the hook"); Test2::API::test2_add_callback_context_acquire($sub); Test2::API::test2_add_callback_context_init($sub); Test2::API::test2_add_callback_context_release($sub); Test2::API::test2_add_callback_exit($sub); Test2::API::test2_add_callback_post_load($sub); is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); done_testing; Test-Simple-1.302125/t/Test2/legacy/0000755000175000017500000000000013243466361016555 5ustar exodistexodistTest-Simple-1.302125/t/Test2/legacy/TAP.t0000644000175000017500000000463113243466361017372 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-FORMATTER use Test2::Tools::Tiny; ######################### # # This test us here to insure that Ok, Diag, and Note events render the way # Test::More renders them, trailing whitespace and all. # ######################### use Test2::API qw/test2_stack context/; # The tools in Test2::Tools::Tiny have some intentional differences from the # Test::More versions, these behave more like Test::More which is important for # back-compat. sub tm_ok($;$) { my ($bool, $name) = @_; my $ctx = context; my $ok = bless { pass => $bool, name => $name, effective_pass => 1, trace => $ctx->trace->snapshot, }, 'Test2::Event::Ok'; # Do not call init $ctx->hub->send($ok); $ctx->release; return $bool; } # Test::More actually does a bit more, but for this test we just want to see # what happens when message is a specific string, or undef. sub tm_diag { my $ctx = context(); $ctx->diag(@_); $ctx->release; } sub tm_note { my $ctx = context(); $ctx->note(@_); $ctx->release; } # Ensure the top hub is generated test2_stack->top; my $temp_hub = test2_stack->new_hub(); require Test::Builder::Formatter; $temp_hub->format(Test::Builder::Formatter->new); my $diag = capture { tm_diag(undef); tm_diag(""); tm_diag(" "); tm_diag("A"); tm_diag("\n"); tm_diag("\nB"); tm_diag("C\n"); tm_diag("\nD\n"); tm_diag("E\n\n"); }; my $note = capture { tm_note(undef); tm_note(""); tm_note(" "); tm_note("A"); tm_note("\n"); tm_note("\nB"); tm_note("C\n"); tm_note("\nD\n"); tm_note("E\n\n"); }; my $ok = capture { tm_ok(1); tm_ok(1, ""); tm_ok(1, " "); tm_ok(1, "A"); tm_ok(1, "\n"); tm_ok(1, "\nB"); tm_ok(1, "C\n"); tm_ok(1, "\nD\n"); tm_ok(1, "E\n\n"); }; test2_stack->pop($temp_hub); is($diag->{STDOUT}, "", "STDOUT is empty for diag"); is($diag->{STDERR}, <{STDERR}, "", "STDERR for note is empty"); is($note->{STDOUT}, <{STDERR}, "", "STDERR for ok is empty"); is($ok->{STDOUT}, <VERSION(2.120920); require Module::Metadata; 1 } or plan skip_all => 'breakage test requires CPAN::Meta, CPAN::Meta::Requirements and Module::Metadata'; my $metafile = -e 'MYMETA.json' ? 'MYMETA.json' : -e 'META.json' ? 'META.json' : undef; unless ($metafile) { plan skip_all => "can't check breakages without some META file"; } eval { my $breaks = CPAN::Meta->load_file($metafile)->custom('x_breaks'); my $reqs = CPAN::Meta::Requirements->new; $reqs->add_string_requirement($_, $breaks->{$_}) foreach keys %$breaks; my $result = check_breaks($reqs); if (my @breaks = grep { defined $result->{$_} } keys %$result) { diag 'You have the following modules installed, which are not compatible with the latest Test::More:'; diag "$result->{$_}" for sort @breaks; diag "\n", 'You should now update these modules!'; diag "You should also see Test2::Transition!"; } pass 'conflicting modules checked'; 1; } or plan skip_all => "Could not check conflicting modules: $@"; # this is an inlined simplification of CPAN::Meta::Check. sub check_breaks { my $reqs = shift; return +{ map { $_ => _check_break($reqs, $_) } $reqs->required_modules, }; } sub _check_break { my ($reqs, $module) = @_; my $metadata = Module::Metadata->new_from_module($module); return undef if not defined $metadata; my $version = eval { $metadata->version }; return "Missing version info for module '$module'" if not $version; return sprintf 'Installed version (%s) of %s is in range \'%s\'', $version, $module, $reqs->requirements_for_module($module) if $reqs->accepts_module($module, $version); return undef; } done_testing; Test-Simple-1.302125/t/Legacy/0000755000175000017500000000000013243466361015514 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/tbm_doesnt_set_exported_to.t0000644000175000017500000000071113243466361023325 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use warnings; # Can't use Test::More, that would set exported_to() use Test::Builder; use Test::Builder::Module; my $TB = Test::Builder->create; $TB->plan( tests => 1 ); $TB->level(0); $TB->is_eq( Test::Builder::Module->builder->exported_to, undef, 'using Test::Builder::Module does not set exported_to()' ); Test-Simple-1.302125/t/Legacy/dont_overwrite_die_handler.t0000644000175000017500000000100313243466361023263 0ustar exodistexodist#!/usr/bin/perl -w use Config; # To prevent conflict with some strawberry-portable versions BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Carp qw/cluck/; # Make sure this is in place before Test::More is loaded. my $started = 0; my $handler_called; BEGIN { $SIG{__DIE__} = sub { $handler_called++; cluck 'Died early!' unless $started }; } use Test::More tests => 2; $started = 1; ok !eval { die }; is $handler_called, 1, 'existing DIE handler not overridden'; Test-Simple-1.302125/t/Legacy/is_deeply_with_threads.t0000644000175000017500000000257113243466361022430 0ustar exodistexodist#!/usr/bin/perl -w # Test to see if is_deeply() plays well with threads. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; BEGIN { unless ( $ENV{AUTHOR_TESTING} ) { print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } use Test::More; my $Num_Threads = 5; plan tests => $Num_Threads * 100 + 6; sub do_one_thread { my $kid = shift; my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', 'hello', 's', 'thisisalongname', '1', '2', '3', 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); my @list2 = @list; print "# kid $kid before is_deeply\n"; for my $j (1..100) { is_deeply(\@list, \@list2); } print "# kid $kid exit\n"; return 42; } my @kids = (); for my $i (1..$Num_Threads) { my $t = threads->new(\&do_one_thread, $i); print "# parent $$: continue\n"; push(@kids, $t); } for my $t (@kids) { print "# parent $$: waiting for join\n"; my $rc = $t->join(); cmp_ok( $rc, '==', 42, "threads exit status is $rc" ); } pass("End of test"); Test-Simple-1.302125/t/Legacy/plan_shouldnt_import.t0000644000175000017500000000044613243466361022151 0ustar exodistexodist#!/usr/bin/perl -w # plan() used to export functions by mistake [rt.cpan.org 8385] BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More (); Test::More::plan(tests => 1); Test::More::ok( !__PACKAGE__->can('ok'), 'plan should not export' ); Test-Simple-1.302125/t/Legacy/00test_harness_check.t0000644000175000017500000000137413243466361021705 0ustar exodistexodist#!/usr/bin/perl -w # A test to make sure the new Test::Harness was installed properly. use Test::More; plan tests => 1; my $TH_Version = 2.03; require Test::Harness; unless( cmp_ok( eval $Test::Harness::VERSION, '>=', $TH_Version, "T::H version" ) ) { diag < 2; { package Foo; use overload 'eq' => \&overload_equiv, '==' => \&overload_equiv; sub new { return bless {}, shift; } sub overload_equiv { if (ref($_[0]) ne 'Foo' || ref($_[1]) ne 'Foo') { print ref($_[0]), " ", ref($_[1]), "\n"; die "Invalid object passed to overload_equiv\n"; } return 1; # change to 0 ... makes little difference } } my $obj1 = Foo->new(); my $obj2 = Foo->new(); eval { is_deeply([$obj1, $obj2], [$obj1, $obj2]); }; is $@, ''; Test-Simple-1.302125/t/Legacy/BEGIN_require_ok.t0000644000175000017500000000071713243466361020757 0ustar exodistexodist#!/usr/bin/perl -w # Fixed a problem with BEGIN { use_ok or require_ok } silently failing when there's no # plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; my $result; BEGIN { $result = require_ok("strict"); } ok $result, "require_ok ran"; done_testing(2); Test-Simple-1.302125/t/Legacy/overload_threads.t0000644000175000017500000000223213243466361021225 0ustar exodistexodist#!perl -w use Test2::Util qw/CAN_THREAD/; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; BEGIN { # There was a bug with overloaded objects and threads. # See rt.cpan.org 4218 eval { require threads; 'threads'->import; 1; } if CAN_THREAD; } use Test::More; plan skip_all => "known to crash on $]" if $] le "5.006002"; plan tests => 5; package Overloaded; use overload q{""} => sub { $_[0]->{string} }; sub new { my $class = shift; bless { string => shift }, $class; } package main; my $warnings = ''; local $SIG{__WARN__} = sub { $warnings = join '', @_ }; # overloaded object as name my $obj = Overloaded->new('foo'); ok( 1, $obj ); # overloaded object which returns undef as name my $undef = Overloaded->new(undef); pass( $undef ); is( $warnings, '' ); TODO: { my $obj = Overloaded->new('not really todo, testing overloaded reason'); local $TODO = $obj; fail("Just checking todo as an overloaded value"); } SKIP: { my $obj = Overloaded->new('not really skipped, testing overloaded reason'); skip $obj, 1; } Test-Simple-1.302125/t/Legacy/explain_err_vars.t0000644000175000017500000000017213243466361021244 0ustar exodistexodistuse strict; use warnings; use Test::More; $@ = 'foo'; explain { 1 => 1 }; is($@, 'foo', "preserved \$@"); done_testing; Test-Simple-1.302125/t/Legacy/Tester/0000755000175000017500000000000013243466361016762 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/Tester/tbt_09do_script.pl0000644000175000017500000000032713243466361022331 0ustar exodistexodist#!/usr/bin/perl use strict; use warnings; isnt($0, __FILE__, 'code is not executing directly'); test_out("not ok 1 - one"); test_fail(+1); ok(0,"one"); test_test('test_fail caught fail message inside a do'); 1; Test-Simple-1.302125/t/Legacy/Tester/tbt_06errormess.t0000644000175000017500000000603113243466361022207 0ustar exodistexodist#!/usr/bin/perl -w use Test::More tests => 8; use Symbol; use Test::Builder; use Test::Builder::Tester; use strict; # argh! now we need to test the thing we're testing. Basically we need # to pretty much reimplement the whole code again. This is very # annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; # ooooh, use the test suite my $t = Test::Builder->new; # remember the testing outputs my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $original_harness_env; my $testing_num; sub start_testing { # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); $original_harness_env = $ENV{HARNESS_ACTIVE}; # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($error_handle); $ENV{HARNESS_ACTIVE} = 0; # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing_num = $t->current_test; $t->current_test(0); } # each test test is actually two tests. This is bad and wrong # but makes blood come out of my ears if I don't at least simplify # it a little this way sub my_test_test { my $text = shift; local $^W = 0; # reset the outputs $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); $ENV{HARNESS_ACTIVE} = $original_harness_env; # reset the number of tests $t->current_test($testing_num); # check we got the same values my $got; my $wanted; # stdout $t->ok($out->check, "STDOUT $text"); # stderr $t->ok($err->check, "STDERR $text"); } #################################################################### # Meta meta tests #################################################################### # this is a quick test to check the hack that I've just implemented # actually does a cut down version of Test::Builder::Tester start_testing(); $out->expect("ok 1 - foo"); pass("foo"); my_test_test("basic meta meta test"); start_testing(); $out->expect("not ok 1 - foo"); $err->expect("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); my_test_test("basic meta meta test 2"); start_testing(); $out->expect("ok 1 - bar"); test_out("ok 1 - foo"); pass("foo"); test_test("bar"); my_test_test("meta meta test with tbt"); start_testing(); $out->expect("ok 1 - bar"); test_out("not ok 1 - foo"); test_err("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); test_test("bar"); my_test_test("meta meta test with tbt2 "); #################################################################### Test-Simple-1.302125/t/Legacy/Tester/tbt_02fhrestore.t0000644000175000017500000000226113243466361022164 0ustar exodistexodist#!/usr/bin/perl use Test::Builder::Tester tests => 4; use Test::More; use Symbol; # create temporary file handles that still point indirectly # to the right place my $orig_o = gensym; my $orig_t = gensym; my $orig_f = gensym; tie *$orig_o, "My::Passthru", \*STDOUT; tie *$orig_t, "My::Passthru", \*STDERR; tie *$orig_f, "My::Passthru", \*STDERR; # redirect the file handles to somewhere else for a mo use Test::Builder; my $t = Test::Builder->new(); $t->output($orig_o); $t->failure_output($orig_f); $t->todo_output($orig_t); # run a test test_out("ok 1 - tested"); ok(1,"tested"); test_test("standard test okay"); # now check that they were restored okay ok($orig_o == $t->output(), "output file reconnected"); ok($orig_t == $t->todo_output(), "todo output file reconnected"); ok($orig_f == $t->failure_output(), "failure output file reconnected"); ##################################################################### package My::Passthru; sub PRINT { my $self = shift; my $handle = $self->[0]; print $handle @_; } sub TIEHANDLE { my $class = shift; my $self = [shift()]; return bless $self, $class; } sub READ {} sub READLINE {} sub GETC {} sub FILENO {} Test-Simple-1.302125/t/Legacy/Tester/tbt_05faildiag.t0000644000175000017500000000147013243466361021727 0ustar exodistexodist#!/usr/bin/perl use Test::Builder::Tester tests => 5; use Test::More; # test_fail test_out("not ok 1 - one"); test_fail(+1); ok(0,"one"); test_out("not ok 2 - two"); test_fail(+2); ok(0,"two"); test_test("test fail"); test_fail(+2); test_out("not ok 1 - one"); ok(0,"one"); test_test("test_fail first"); # test_diag use Test::Builder; my $test = new Test::Builder; test_diag("this is a test string","so is this"); $test->diag("this is a test string\n", "so is this\n"); test_test("test diag"); test_diag("this is a test string","so is this"); $test->diag("this is a test string\n"); $test->diag("so is this\n"); test_test("test diag multi line"); test_diag("this is a test string"); test_diag("so is this"); $test->diag("this is a test string\n"); $test->diag("so is this\n"); test_test("test diag multiple"); Test-Simple-1.302125/t/Legacy/Tester/tbt_04line_num.t0000644000175000017500000000030413243466361021767 0ustar exodistexodist#!/usr/bin/perl use Test::More tests => 3; use Test::Builder::Tester; is(line_num(),6,"normal line num"); is(line_num(-1),6,"line number minus one"); is(line_num(+2),10,"line number plus two"); Test-Simple-1.302125/t/Legacy/Tester/tbt_08subtest.t0000644000175000017500000000041413243466361021660 0ustar exodistexodist#!/usr/bin/env perl # HARNESS-NO-STREAM use strict; use warnings; use Test::Builder::Tester tests => 1; use Test::More; subtest 'foo' => sub { plan tests => 1; test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); }; Test-Simple-1.302125/t/Legacy/Tester/tbt_01basic.t0000644000175000017500000000237213243466361021246 0ustar exodistexodist#!/usr/bin/perl use Test::Builder::Tester tests => 10; use Test::More; ok(1,"This is a basic test"); test_out("ok 1 - tested"); ok(1,"tested"); test_test("captured okay on basic"); test_out("ok 1 - tested"); ok(1,"tested"); test_test("captured okay again without changing number"); ok(1,"test unrelated to Test::Builder::Tester"); test_out("ok 1 - one"); test_out("ok 2 - two"); ok(1,"one"); ok(2,"two"); test_test("multiple tests"); test_out(qr/ok 1 - tested\n/); ok(1,"tested"); test_test("regexp matching"); test_out("not ok 1 - should fail"); test_err("# Failed test ($0 at line 32)"); test_err("# got: 'foo'"); test_err("# expected: 'bar'"); is("foo","bar","should fail"); test_test("testing failing"); test_out("not ok 1"); test_out("not ok 2"); test_fail(+2); test_fail(+1); fail(); fail(); test_test("testing failing on the same line with no name"); test_out("not ok 1 - name"); test_out("not ok 2 - name"); test_fail(+2); test_fail(+1); fail("name"); fail("name"); test_test("testing failing on the same line with the same name"); test_out("not ok 1 - name # TODO Something"); test_out("# Failed (TODO) test ($0 at line 56)"); TODO: { local $TODO = "Something"; fail("name"); } test_test("testing failing with todo"); Test-Simple-1.302125/t/Legacy/Tester/tbt_07args.t0000644000175000017500000001223413243466361021125 0ustar exodistexodist#!/usr/bin/perl -w use Test::More tests => 18; use Symbol; use Test::Builder; use Test::Builder::Tester; use strict; # argh! now we need to test the thing we're testing. Basically we need # to pretty much reimplement the whole code again. This is very # annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; # ooooh, use the test suite my $t = Test::Builder->new; # remember the testing outputs my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $testing_num; my $original_harness_env; sub start_testing { # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); $original_harness_env = $ENV{HARNESS_ACTIVE}; # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($error_handle); $ENV{HARNESS_ACTIVE} = 0; # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing_num = $t->current_test; $t->current_test(0); } # each test test is actually two tests. This is bad and wrong # but makes blood come out of my ears if I don't at least simplify # it a little this way sub my_test_test { my $text = shift; local $^W = 0; # reset the outputs $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); $ENV{HARNESS_ACTIVE} = $original_harness_env; # reset the number of tests $t->current_test($testing_num); # check we got the same values my $got; my $wanted; # stdout $t->ok($out->check, "STDOUT $text"); # stderr $t->ok($err->check, "STDERR $text"); } #################################################################### # Meta meta tests #################################################################### # this is a quick test to check the hack that I've just implemented # actually does a cut down version of Test::Builder::Tester start_testing(); $out->expect("ok 1 - foo"); pass("foo"); my_test_test("basic meta meta test"); start_testing(); $out->expect("not ok 1 - foo"); $err->expect("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); my_test_test("basic meta meta test 2"); start_testing(); $out->expect("ok 1 - bar"); test_out("ok 1 - foo"); pass("foo"); test_test("bar"); my_test_test("meta meta test with tbt"); start_testing(); $out->expect("ok 1 - bar"); test_out("not ok 1 - foo"); test_err("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); test_test("bar"); my_test_test("meta meta test with tbt2 "); #################################################################### # Actual meta tests #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(name => "bar"); # check that passed my_test_test("meta test name"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(title => "bar"); # check that passed my_test_test("meta test title"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(label => "bar"); # check that passed my_test_test("meta test title"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("not ok 1 - foo this is wrong"); test_fail(+3); # the actual test function that we are testing ok("0","foo"); # test that we got what we expect, ignoring our is wrong test_test(skip_out => 1, name => "bar"); # check that that passed my_test_test("meta test skip_out"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("not ok 1 - foo"); test_err("this is wrong"); # the actual test function that we are testing ok("0","foo"); # test that we got what we expect, ignoring err is wrong test_test(skip_err => 1, name => "bar"); # diagnostics failing out # check that that passed my_test_test("meta test skip_err"); #################################################################### Test-Simple-1.302125/t/Legacy/Tester/tbt_03die.t0000644000175000017500000000034113243466361020722 0ustar exodistexodist#!/usr/bin/perl use Test::Builder::Tester tests => 1; use Test::More; eval { test_test("foo"); }; like($@, "/Not testing\. You must declare output with a test function first\./", "dies correctly on error"); Test-Simple-1.302125/t/Legacy/Tester/tbt_09do.t0000644000175000017500000000110613243466361020571 0ustar exodistexodist#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester tests => 3; use Test::More; use File::Basename qw(dirname); use File::Spec qw(); my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); $file = File::Spec->catfile(File::Spec->curdir(), $file) unless File::Spec->file_name_is_absolute($file); my $done = do $file; ok(defined($done), 'do succeeded') or do { if ($@) { diag qq( \$@ is '$@'\n); } elsif ($!) { diag qq( \$! is '$!'\n); } else { diag qq( file's last statement returned undef: $file) } }; Test-Simple-1.302125/t/Legacy/478-cmp_ok_hash.t0000644000175000017500000000163313243466361020477 0ustar exodistexodistuse strict; use warnings; use Test::More; my $want = 0; my $got = 0; cmp_ok($got, 'eq', $want, "Passes on correct comparison"); my ($res, @ok, @diag, @warn); { no warnings 'redefine'; local *Test::Builder::ok = sub { my ($tb, $ok, $name) = @_; push @ok => $ok; return $ok; }; local *Test::Builder::diag = sub { my ($tb, @d) = @_; push @diag => @d; }; local $SIG{__WARN__} = sub { push @warn => @_; }; $res = cmp_ok($got, '#eq', $want, "You shall not pass!"); } ok(!$res, "Did not pass"); is(@ok, 1, "1 result"); ok(!$ok[0], "result is false"); # We only care that it mentions a syntax error. like(join("\n" => @diag), qr/syntax error at \(eval in cmp_ok\)/, "Syntax error"); # We are not going to inspect the warning because it is not super predictable, # and changes with eval specifics. ok(@warn, "We got warnings"); done_testing; Test-Simple-1.302125/t/Legacy/Regression/0000755000175000017500000000000013243466361017634 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/Regression/683_thread_todo.t0000644000175000017500000000065413243466361022722 0ustar exodistexodistuse strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; use Test::More; my $t = threads->create( sub { local $TODO = "Some good reason"; fail "Crap"; 42; } ); is( $t->join, 42, "Thread exitted successfully" ); done_testing; Test-Simple-1.302125/t/Legacy/Regression/789-read-only.t0000644000175000017500000000124013243466361022235 0ustar exodistexodistuse Test::More; use strict; use warnings; # HARNESS-NO-STREAM # See https://github.com/Test-More/test-more/issues/789 BEGIN { plan skip_all => 'AUTHOR_TESTING not enabled' unless $ENV{AUTHOR_TESTING}; plan skip_all => "This test requires Test::Class" unless eval { require Test::Class; 1 }; plan skip_all => "This test requires Test::Script" unless eval { require Test::Script; 1 }; } package Test; use base 'Test::Class'; use Test::More; use Test::Script; sub a_compilation_test : Test(startup => 1) { script_compiles(__FILE__); } sub test : Test(1) { ok(1); } package main; use Test::Class; Test::Class->runtests; Test-Simple-1.302125/t/Legacy/Regression/736_use_ok.t0000644000175000017500000000141613243466361021707 0ustar exodistexodistuse warnings; use strict; use Test::More; BEGIN { $INC{'MyWarner.pm'} = 1; package MyWarner; sub import { warnings::warnif('deprecated', "Deprected! run for your lives!"); } } sub capture(&) { my $warn; local $SIG{__WARN__} = sub { $warn = shift }; $_[0]->(); return $warn || ""; } { local $TODO = "known to fail on $]" if $] le "5.006002"; my $file = __FILE__; my $line = __LINE__ + 4; like( capture { local $TODO; # localize $TODO to clear previous assignment, as following use_ok test is expected to pass use_ok 'MyWarner'; }, qr/^Deprected! run for your lives! at \Q$file\E line $line/, "Got the warning" ); } ok(!capture { no warnings 'deprecated'; use_ok 'MyWarner' }, "No warning"); done_testing; Test-Simple-1.302125/t/Legacy/Regression/6_cmp_ok.t0000644000175000017500000000041113243466361021512 0ustar exodistexodistuse Test::More; use Test2::API qw/intercept/; my $events = intercept { local $SIG{__WARN__} = sub { 1 }; my $foo = undef; cmp_ok($foo, "ne", ""); }; is($events->[-1]->message, < "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); ok 1 for (1 .. 2); # used to reset the counter after thread finishes my $ct_num = Test::More->builder->current_test; my $subtest_out = async { my $out = ''; #simulate a subtest to not confuse the parent TAP emission my $tb = Test::More->builder; $tb->reset; for (qw/output failure_output todo_output/) { close $tb->$_; open($tb->$_, '>', \$out); } ok 1 for (1 .. 3); done_testing; close $tb->$_ for (qw/output failure_output todo_output/); $out; } ->join; $subtest_out =~ s/^/ /gm; print $subtest_out; # reset as if the thread never "said" anything Test::More->builder->current_test($ct_num); ok 1 for (1 .. 4); done_testing; Test-Simple-1.302125/t/Legacy/plan_is_noplan.t0000644000175000017500000000062413243466361020677 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 1; use Test::Builder::NoOutput; { my $tb = Test::Builder::NoOutput->create; $tb->plan('no_plan'); $tb->ok(1, 'foo'); $tb->_ending; is($tb->read, <create; $TB->plan(tests => 4); # Utility testing functions. sub ok ($;$) { return $TB->ok(@_); } sub main::err_ok ($) { my($expect) = @_; my $got = $err->read; return $TB->is_eq( $got, $expect ); } package main; require Test::More; Test::More->import(tests => 4); Test::More->builder->no_ending(1); { local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; #line 62 fail( "this fails" ); err_ok( <new->no_header(1); Test::Builder->new->no_ending(1); local $ENV{HARNESS_ACTIVE} = 0; # Can't use Test.pm, that's a 5.005 thing. package main; my $TB = Test::Builder->create; $TB->plan(tests => 102); # Utility testing functions. sub ok ($;$) { return $TB->ok(@_); } sub is ($$;$) { my($thing, $that, $name) = @_; my $ok = $TB->is_eq($$thing, $that, $name); $$thing = ''; return $ok; } sub like ($$;$) { my($thing, $regex, $name) = @_; $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; my $ok = $TB->like($$thing, $regex, $name); $$thing = ''; return $ok; } require Test::More; Test::More->import(tests => 11, import => ['is_deeply']); my $Filename = quotemeta $0; #line 68 ok !is_deeply('foo', 'bar', 'plain strings'); is( $out, "not ok 1 - plain strings\n", 'plain strings' ); is( $err, < 42 }, { this => 43 }, 'hashes with different values'); is( $out, "not ok 3 - hashes with different values\n", 'hashes with different values' ); is( $err, <{this} = '42' # \$expected->{this} = '43' ERR #line 99 ok !is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); is( $out, "not ok 4 - hashes with different keys\n", 'hashes with different keys' ); is( $err, <{this} = Does not exist # \$expected->{this} = '42' ERR #line 110 ok !is_deeply([1..9], [1..10], 'arrays of different length'); is( $out, "not ok 5 - arrays of different length\n", 'arrays of different length' ); is( $err, <[9] = Does not exist # \$expected->[9] = '10' ERR #line 121 ok !is_deeply([undef, undef], [undef], 'arrays of undefs' ); is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); is( $err, <[1] = undef # \$expected->[1] = Does not exist ERR #line 131 ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' ); is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); is( $err, <{foo} = undef # \$expected->{foo} = Does not exist ERR #line 141 ok !is_deeply(\42, \23, 'scalar refs'); is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); is( $err, < \$a3 }; # $b2 = { foo => \$b3 }; # is_deeply([$a1], [$b1], 'deep mixed scalar refs'); my $foo = { this => [1..10], that => { up => "down", left => "right" }, }; my $bar = { this => [1..10], that => { up => "down", left => "right", foo => 42 }, }; #line 198 ok !is_deeply( $foo, $bar, 'deep structures' ); ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); is( $out, "not ok 11 - deep structures\n", 'deep structures' ); is( $err, <{that}{foo} = Does not exist # \$expected->{that}{foo} = '42' ERR #line 221 my @tests = ([], [qw(42)], [qw(42 23), qw(42 23)] ); foreach my $test (@tests) { my $num_args = @$test; my $warning; local $SIG{__WARN__} = sub { $warning .= join '', @_; }; ok !is_deeply(@$test); like \$warning, "/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/"; } #line 240 # [rt.cpan.org 6837] ok !is_deeply([{Foo => undef}],[{Foo => ""}]), 'undef != ""'; ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); #line 258 # [rt.cpan.org 7031] my $a = []; ok !is_deeply($a, $a.''), "don't compare refs like strings"; ok !is_deeply([$a], [$a.'']), " even deep inside"; #line 265 # [rt.cpan.org 7030] ok !is_deeply( {}, {key => []} ), '[] could match non-existent values'; ok !is_deeply( [], [[]] ); #line 273 $$err = $$out = ''; ok !is_deeply( [\'a', 'b'], [\'a', 'c'] ); is( $out, "not ok 20\n", 'scalar refs in an array' ); is( $err, <[1] = 'b' # \$expected->[1] = 'c' ERR #line 285 my $ref = \23; ok !is_deeply( 23, $ref ); is( $out, "not ok 21\n", 'scalar vs ref' ); is( $err, <[0] = $array # \$expected->[0] = $hash ERR # Overloaded object tests { my $foo = bless [], "Foo"; my $bar = bless {}, "Bar"; { package Bar; "overload"->import(q[""] => sub { "wibble" }); } #line 353 ok !is_deeply( [$foo], [$bar] ); is( $out, "not ok 26\n", 'string overloaded refs respected in diag' ); is( $err, <[0] = $foo # \$expected->[0] = 'wibble' ERR } } # rt.cpan.org 14746 { # line 349 ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs'; is( $out, "not ok 27\n" ); like( $err, < 0}, {x => ''}, "{x => 0} != {x => ''}" ); is( $out, "not ok 39 - {x => 0} != {x => ''}\n" ); ok !is_deeply( {x => 0}, {x => undef}, "{x => 0} != {x => undef}" ); is( $out, "not ok 40 - {x => 0} != {x => undef}\n" ); ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" ); is( $out, "not ok 41 - {x => ''} != {x => undef}\n" ); } # this will also happily fail before 5.10, even though there's no VSTRING ref type { my $version1 = v1.2.3; my $version2 = v1.2.4; ok !is_deeply( [\\$version1], [\\$version2], "version objects"); is( $out, "not ok 42 - version objects\n" ); } Test-Simple-1.302125/t/Legacy/no_log_results.t0000644000175000017500000000040413243466361020735 0ustar exodistexodistuse strict; use warnings; use Test::More; sub it { my $tb = Test::Builder->new; $tb->no_log_results; ok(1, "sample"); ok(2, "sample"); is_deeply([$tb->details], [], "no details were logged"); } it(); subtest it => \⁢ done_testing; Test-Simple-1.302125/t/Legacy/Test2/0000755000175000017500000000000013243466361016515 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/Test2/Subtest.t0000644000175000017500000000124713243466361020337 0ustar exodistexodistuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my $res = intercept { subtest foo => sub { ok(1, "check"); }; }; is(@$res, 2, "2 results"); isa_ok($res->[0], 'Test2::Event::Note'); is($res->[0]->message, 'Subtest: foo', "got subtest note"); isa_ok($res->[1], 'Test2::Event::Subtest'); ok($res->[1]->pass, "subtest passed"); my $subs = $res->[1]->subevents; is(@$subs, 2, "got all subevents"); isa_ok($subs->[0], 'Test2::Event::Ok'); is($subs->[0]->pass, 1, "subtest ok passed"); is($subs->[0]->name, 'check', "subtest ok name"); isa_ok($subs->[1], 'Test2::Event::Plan'); is($subs->[1]->max, 1, "subtest plan is 1"); done_testing; Test-Simple-1.302125/t/Legacy/plan_skip_all.t0000644000175000017500000000027613243466361020516 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan skip_all => 'Just testing plan & skip_all'; fail('We should never get here'); Test-Simple-1.302125/t/Legacy/circular_data.t0000644000175000017500000000226013243466361020476 0ustar exodistexodist#!/usr/bin/perl -w # Test is_deeply and friends with circular data structures [rt.cpan.org 7289] BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 11; my $a1 = [ 1, 2, 3 ]; push @$a1, $a1; my $a2 = [ 1, 2, 3 ]; push @$a2, $a2; is_deeply $a1, $a2; ok( eq_array ($a1, $a2) ); ok( eq_set ($a1, $a2) ); my $h1 = { 1=>1, 2=>2, 3=>3 }; $h1->{4} = $h1; my $h2 = { 1=>1, 2=>2, 3=>3 }; $h2->{4} = $h2; is_deeply $h1, $h2; ok( eq_hash ($h1, $h2) ); my ($r, $s); $r = \$r; $s = \$s; ok( eq_array ([$s], [$r]) ); { # Classic set of circular scalar refs. my($a,$b,$c); $a = \$b; $b = \$c; $c = \$a; my($d,$e,$f); $d = \$e; $e = \$f; $f = \$d; is_deeply( $a, $a ); is_deeply( $a, $d ); } { # rt.cpan.org 11623 # Make sure the circular ref checks don't get confused by a reference # which is simply repeating. my $a = {}; my $b = {}; my $c = {}; is_deeply( [$a, $a], [$b, $c] ); is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } ); is_deeply( [\$a, \$a], [\$b, \$c] ); } Test-Simple-1.302125/t/Legacy/BEGIN_use_ok.t0000644000175000017500000000060413243466361020072 0ustar exodistexodist#!/usr/bin/perl -w # [rt.cpan.org 28345] # # A use_ok() inside a BEGIN block lacking a plan would be silently ignored. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; my $result; BEGIN { $result = use_ok("strict"); } ok( $result, "use_ok() ran" ); done_testing(2); Test-Simple-1.302125/t/Legacy/plan_no_plan.t0000644000175000017500000000143213243466361020341 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; BEGIN { if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { plan skip_all => "Won't work with t/TEST"; } } plan 'no_plan'; pass('Just testing'); ok(1, 'Testing again'); { my $warning = ''; local $SIG{__WARN__} = sub { $warning = join "", @_ }; SKIP: { skip 'Just testing skip with no_plan'; fail("So very failed"); } is( $warning, '', 'skip with no "how_many" ok with no_plan' ); $warning = ''; TODO: { todo_skip "Just testing todo_skip"; fail("Just testing todo"); die "todo_skip should prevent this"; pass("Again"); } is( $warning, '', 'skip with no "how_many" ok with no_plan' ); } Test-Simple-1.302125/t/Legacy/thread_taint.t0000644000175000017500000000017213243466361020347 0ustar exodistexodist#!/usr/bin/perl -w use Test::More tests => 1; ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); Test-Simple-1.302125/t/Legacy/Simple/0000755000175000017500000000000013243466361016745 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/Simple/load.t0000644000175000017500000000026413243466361020053 0ustar exodistexodist#!/usr/bin/perl # Because I broke "use Test::Simple", here's a test use strict; use warnings; use Test::Simple; print <create; # TB methods expect to be wrapped sub ok { $tb->ok(@_) } sub plan { $tb->plan(@_) } sub done_testing { $tb->done_testing(@_) } { # Normalize test output local $ENV{HARNESS_ACTIVE}; plan( tests => 3 ); ok(1); ok(1); ok(1); #line 24 done_testing(2); } my $Test = Test::Builder->new; $Test->plan( tests => 1 ); $Test->level(0); $Test->is_eq($tb->read, <<"END"); 1..3 ok 1 ok 2 ok 3 not ok 4 - planned to run 3 but done_testing() expects 2 # Failed test 'planned to run 3 but done_testing() expects 2' # at $0 line 24. END Test-Simple-1.302125/t/Legacy/Builder/done_testing_with_no_plan.t0000644000175000017500000000023013243466361024505 0ustar exodistexodist#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->plan( "no_plan" ); $tb->ok(1); $tb->ok(1); $tb->done_testing(2); Test-Simple-1.302125/t/Legacy/Builder/current_test_without_plan.t0000644000175000017500000000035113243466361024604 0ustar exodistexodist#!/usr/bin/perl -w # Test that current_test() will work without a declared plan. use Test::Builder; my $tb = Test::Builder->new; $tb->current_test(2); print <<'END'; ok 1 ok 2 END $tb->ok(1, "Third test"); $tb->done_testing(3); Test-Simple-1.302125/t/Legacy/Builder/done_testing_with_number.t0000644000175000017500000000035413243466361024356 0ustar exodistexodist#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->level(0); $tb->ok(1, "testing done_testing() with no arguments"); $tb->ok(1, " another test so we're not testing just one"); $tb->done_testing(2); Test-Simple-1.302125/t/Legacy/Builder/done_testing_with_plan.t0000644000175000017500000000023113243466361024012 0ustar exodistexodist#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->plan( tests => 2 ); $tb->ok(1); $tb->ok(1); $tb->done_testing(2); Test-Simple-1.302125/t/Legacy/Builder/fork_with_new_stdout.t0000644000175000017500000000147413243466361023544 0ustar exodistexodist#!perl -w use strict; use warnings; use Test2::Util qw/CAN_FORK/; BEGIN { unless (CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } use IO::Pipe; use Test::Builder; use Config; my $b = Test::Builder->new; $b->reset; $b->plan('tests' => 2); my $pipe = IO::Pipe->new; if (my $pid = fork) { $pipe->reader; my ($one, $two) = <$pipe>; $b->like($one, qr/ok 1/, "ok 1 from child"); $b->like($two, qr/1\.\.1/, "1..1 from child"); waitpid($pid, 0); } else { require Test::Builder::Formatter; $b->{Stack}->top->format(Test::Builder::Formatter->new()); $pipe->writer; $b->reset; $b->no_plan; $b->output($pipe); $b->ok(1); $b->done_testing; } =pod #actual 1..2 ok 1 1..1 ok 1 ok 2 #expected 1..2 ok 1 ok 2 =cut Test-Simple-1.302125/t/Legacy/Builder/done_testing_double.t0000644000175000017500000000175213243466361023310 0ustar exodistexodist#!/usr/bin/perl -w use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; # $tb methods expect to be wrapped in at least 1 sub sub done_testing { $tb->done_testing(@_) } sub ok { $tb->ok(@_) } { # Normalize test output local $ENV{HARNESS_ACTIVE}; ok(1); ok(1); ok(1); #line 24 done_testing(3); done_testing; done_testing; } my $Test = Test::Builder->new; $Test->plan( tests => 1 ); $Test->level(0); $Test->is_eq($tb->read, <<"END", "multiple done_testing"); ok 1 ok 2 ok 3 1..3 not ok 4 - done_testing() was already called at $0 line 24 # Failed test 'done_testing() was already called at $0 line 24' # at $0 line 25. not ok 5 - done_testing() was already called at $0 line 24 # Failed test 'done_testing() was already called at $0 line 24' # at $0 line 26. END Test-Simple-1.302125/t/Legacy/Builder/no_plan_at_all.t0000644000175000017500000000132213243466361022227 0ustar exodistexodist#!/usr/bin/perl -w # Test what happens when no plan is declared and done_testing() is not seen use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::Builder::NoOutput; my $Test = Test::Builder->new; $Test->level(0); $Test->plan( tests => 1 ); my $tb = Test::Builder::NoOutput->create; { $tb->level(0); $tb->ok(1, "just a test"); $tb->ok(1, " and another"); $tb->_ending; } $Test->is_eq($tb->read, <<'END', "proper behavior when no plan is seen"); ok 1 - just a test ok 2 - and another # Tests were run but no plan was declared and done_testing() was not seen. END Test-Simple-1.302125/t/Legacy/Builder/reset_outputs.t0000644000175000017500000000142013243466361022211 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::More 'no_plan'; { my $tb = Test::Builder->create(); # Store the original output filehandles and change them all. my %original_outputs; open my $fh, ">", "dummy_file.tmp"; END { 1 while unlink "dummy_file.tmp"; } for my $method (qw(output failure_output todo_output)) { $original_outputs{$method} = $tb->$method(); $tb->$method($fh); is $tb->$method(), $fh; } $tb->reset_outputs; for my $method (qw(output failure_output todo_output)) { is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method"; } } Test-Simple-1.302125/t/Legacy/Builder/done_testing.t0000644000175000017500000000035313243466361021752 0ustar exodistexodist#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->level(0); $tb->ok(1, "testing done_testing() with no arguments"); $tb->ok(1, " another test so we're not testing just one"); $tb->done_testing(); Test-Simple-1.302125/t/Legacy/Builder/current_test.t0000644000175000017500000000040313243466361022005 0ustar exodistexodist#!/usr/bin/perl -w # Dave Rolsky found a bug where if current_test() is used and no # tests are run via Test::Builder it will blow up. use Test::Builder; $TB = Test::Builder->new; $TB->plan(tests => 2); print "ok 1\n"; print "ok 2\n"; $TB->current_test(2); Test-Simple-1.302125/t/Legacy/Builder/maybe_regex.t0000644000175000017500000000244213243466361021560 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 16; use Test::Builder; my $Test = Test::Builder->new; my $r = $Test->maybe_regex(qr/^FOO$/i); ok(defined $r, 'qr// detected'); ok(('foo' =~ /$r/), 'qr// good match'); ok(('bar' !~ /$r/), 'qr// bad match'); SKIP: { skip "blessed regex checker added in 5.10", 3 if $] < 5.010; my $obj = bless qr/foo/, 'Wibble'; my $re = $Test->maybe_regex($obj); ok( defined $re, "blessed regex detected" ); ok( ('foo' =~ /$re/), 'blessed qr/foo/ good match' ); ok( ('bar' !~ /$re/), 'blessed qr/foo/ bad math' ); } { my $r = $Test->maybe_regex('/^BAR$/i'); ok(defined $r, '"//" detected'); ok(('bar' =~ m/$r/), '"//" good match'); ok(('foo' !~ m/$r/), '"//" bad match'); }; { my $r = $Test->maybe_regex('not a regex'); ok(!defined $r, 'non-regex detected'); }; { my $r = $Test->maybe_regex('/0/'); ok(defined $r, 'non-regex detected'); ok(('f00' =~ m/$r/), '"//" good match'); ok(('b4r' !~ m/$r/), '"//" bad match'); }; { my $r = $Test->maybe_regex('m,foo,i'); ok(defined $r, 'm,, detected'); ok(('fOO' =~ m/$r/), '"//" good match'); ok(('bar' !~ m/$r/), '"//" bad match'); }; Test-Simple-1.302125/t/Legacy/Builder/is_passing.t0000644000175000017500000000434713243466361021436 0ustar exodistexodist#!/usr/bin/perl -w use strict; use lib 't/lib'; # We're going to need to override exit() later BEGIN { require Test2::Hub; no warnings 'redefine'; *Test2::Hub::terminate = sub { my $status = @_ ? 0 : shift; CORE::exit $status; }; } use Test::More; use Test::Builder; use Test::Builder::NoOutput; { my $tb = Test::Builder::NoOutput->create; ok $tb->is_passing, "a fresh TB object is passing"; $tb->ok(1); ok $tb->is_passing, " still passing after a test"; $tb->ok(0); ok !$tb->is_passing, " not passing after a failing test"; $tb->ok(1); ok !$tb->is_passing, " a passing test doesn't resurrect it"; $tb->done_testing(3); ok !$tb->is_passing, " a successful plan doesn't help either"; } # See if is_passing() notices a plan overrun { my $tb = Test::Builder::NoOutput->create; $tb->plan( tests => 1 ); $tb->ok(1); ok $tb->is_passing, "Passing with a plan"; $tb->ok(1); ok !$tb->is_passing, " passing test, but it overran the plan"; } # is_passing() vs no_plan { my $tb = Test::Builder::NoOutput->create; $tb->plan( "no_plan" ); ok $tb->is_passing, "Passing with no_plan"; $tb->ok(1); ok $tb->is_passing, " still passing after a test"; $tb->ok(1); ok $tb->is_passing, " and another test"; $tb->_ending; ok $tb->is_passing, " and after the ending"; } # is_passing() vs skip_all { my $tb = Test::Builder::NoOutput->create; { no warnings 'redefine'; local *Test2::Hub::terminate = sub { 1 }; $tb->plan( "skip_all" ); } ok $tb->is_passing, "Passing with skip_all"; } # is_passing() vs done_testing(#) { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $tb->done_testing(2); ok !$tb->is_passing, "All tests passed but done_testing() does not match"; } # is_passing() with no tests run vs done_testing() { my $tb = Test::Builder::NoOutput->create; $tb->done_testing(); ok !$tb->is_passing, "No tests run with done_testing()"; } # is_passing() with no tests run vs done_testing() { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $tb->done_testing(); ok $tb->is_passing, "All tests passed with done_testing()"; } done_testing(); Test-Simple-1.302125/t/Legacy/Builder/no_ending.t0000644000175000017500000000055513243466361021234 0ustar exodistexodistuse Test::Builder; # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } BEGIN { my $t = Test::Builder->new; $t->no_ending(1); } use Test::More tests => 3; # Normally, Test::More would yell that we ran too few tests, but we # suppressed the ending diagnostics. pass; print "ok 2\n"; print "ok 3\n"; Test-Simple-1.302125/t/Legacy/Builder/has_plan2.t0000644000175000017500000000054313243466361021140 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; BEGIN { if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { plan skip_all => "Won't work with t/TEST"; } } use strict; use Test::Builder; plan 'no_plan'; is(Test::Builder->new->has_plan, 'no_plan', 'has no_plan'); Test-Simple-1.302125/t/Legacy/Builder/no_header.t0000644000175000017500000000045213243466361021214 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; # STDOUT must be unbuffered else our prints might come out after # Test::More's. $| = 1; BEGIN { Test::Builder->new->no_header(1); } use Test::More tests => 1; print "1..1\n"; pass; Test-Simple-1.302125/t/Legacy/Builder/has_plan.t0000644000175000017500000000055613243466361021062 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib'); } } use strict; use Test::Builder; my $unplanned; BEGIN { $unplanned = 'oops'; $unplanned = Test::Builder->new->has_plan; }; use Test::More tests => 2; is($unplanned, undef, 'no plan yet defined'); is(Test::Builder->new->has_plan, 2, 'has fixed plan'); Test-Simple-1.302125/t/Legacy/Builder/details.t0000644000175000017500000000577613243466361020733 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 9 ); $Test->level(0); my @Expected_Details; $Test->is_num( scalar $Test->summary(), 0, 'no tests yet, no summary' ); push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => 'no tests yet, no summary', type => '', reason => '' }; # Inline TODO tests will confuse pre 1.20 Test::Harness, so we # should just avoid the problem and not print it out. my $start_test = $Test->current_test + 1; my $output = ''; $Test->output(\$output); $Test->todo_output(\$output); SKIP: { $Test->skip( 'just testing skip' ); } push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => 'just testing skip', }; TODO: { local $TODO = 'i need a todo'; $Test->ok( 0, 'a test to todo!' ); push @Expected_Details, { 'ok' => 1, actual_ok => 0, name => 'a test to todo!', type => 'todo', reason => 'i need a todo', }; $Test->todo_skip( 'i need both' ); } push @Expected_Details, { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => 'i need both' }; for ($start_test..$Test->current_test) { print "ok $_\n" } $Test->reset_outputs; $Test->is_num( scalar $Test->summary(), 4, 'summary' ); push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => 'summary', type => '', reason => '', }; $Test->current_test(6); print "ok 6 - current_test incremented\n"; push @Expected_Details, { 'ok' => 1, actual_ok => undef, name => undef, type => 'unknown', reason => 'incrementing test number', }; my @details = $Test->details(); $Test->is_num( scalar @details, 6, 'details() should return a list of all test details'); $Test->level(1); is_deeply( \@details, \@Expected_Details ); # This test has to come last because it thrashes the test details. { my $curr_test = $Test->current_test; $Test->current_test(4); my @details = $Test->details(); $Test->current_test($curr_test); $Test->is_num( scalar @details, 4 ); } Test-Simple-1.302125/t/Legacy/Builder/Builder.t0000644000175000017500000000121713243466361020656 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 7 ); my $default_lvl = $Test->level; $Test->level(0); $Test->ok( 1, 'compiled and new()' ); $Test->ok( $default_lvl == 1, 'level()' ); $Test->is_eq('foo', 'foo', 'is_eq'); $Test->is_num('23.0', '23', 'is_num'); $Test->is_num( $Test->current_test, 4, 'current_test() get' ); my $test_num = $Test->current_test + 1; $Test->current_test( $test_num ); print "ok $test_num - current_test() set\n"; $Test->ok( 1, 'counter still good' ); Test-Simple-1.302125/t/Legacy/Builder/no_diag.t0000644000175000017500000000046613243466361020675 0ustar exodistexodist#!/usr/bin/perl -w use Test::More 'no_diag'; plan 'skip_all' => "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); pass('foo'); diag('This should not be displayed'); is(Test::More->builder->no_diag, 1); done_testing; Test-Simple-1.302125/t/Legacy/Builder/create.t0000644000175000017500000000146213243466361020535 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More tests => 7; use Test::Builder; use Test::Builder::NoOutput; my $more_tb = Test::More->builder; isa_ok $more_tb, 'Test::Builder'; is $more_tb, Test::More->builder, 'create does not interfere with ->builder'; is $more_tb, Test::Builder->new, ' does not interfere with ->new'; { my $new_tb = Test::Builder::NoOutput->create; isa_ok $new_tb, 'Test::Builder'; isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; $new_tb->plan(tests => 1); $new_tb->ok(1, "a test"); is $new_tb->read, <<'OUT'; 1..1 ok 1 - a test OUT } pass("Changing output() of new TB doesn't interfere with singleton"); Test-Simple-1.302125/t/Legacy/Builder/output.t0000644000175000017500000000371313243466361020633 0ustar exodistexodist#!perl -w use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder; # The real Test::Builder my $Test = Test::Builder->new; $Test->plan( tests => 6 ); # The one we're going to test. my $tb = Test::Builder->create(); my $tmpfile = 'foo.tmp'; END { 1 while unlink($tmpfile) } # Test output to a file { my $out = $tb->output($tmpfile); $Test->ok( defined $out ); print $out "hi!\n"; close *$out; undef $out; open(IN, $tmpfile) or die $!; chomp(my $line = ); close IN; $Test->is_eq($line, 'hi!'); } # Test output to a filehandle { open(FOO, ">>$tmpfile") or die $!; my $out = $tb->output(\*FOO); my $old = select *$out; print "Hello!\n"; close *$out; undef $out; select $old; open(IN, $tmpfile) or die $!; my @lines = ; close IN; $Test->like($lines[1], qr/Hello!/); } # Test output to a scalar ref { my $scalar = ''; my $out = $tb->output(\$scalar); print $out "Hey hey hey!\n"; $Test->is_eq($scalar, "Hey hey hey!\n"); } # Test we can output to the same scalar ref { my $scalar = ''; my $out = $tb->output(\$scalar); my $err = $tb->failure_output(\$scalar); print $out "To output "; print $err "and beyond!"; $Test->is_eq($scalar, "To output and beyond!", "One scalar, two filehandles"); } # Ensure stray newline in name escaping works. { my $fakeout = ''; my $out = $tb->output(\$fakeout); $tb->exported_to(__PACKAGE__); $tb->no_ending(1); $tb->plan(tests => 5); $tb->ok(1, "ok"); $tb->ok(1, "ok\n"); $tb->ok(1, "ok, like\nok"); $tb->skip("wibble\nmoof"); $tb->todo_skip("todo\nskip\n"); $Test->is_eq( $fakeout, < 4; package Foo; my $destroyed = 0; sub new { bless {}, shift } sub DESTROY { $destroyed++; } package main; for (1..3) { ok(my $foo = Foo->new, 'created Foo object'); } is $destroyed, 3, "DESTROY called 3 times"; Test-Simple-1.302125/t/Legacy/Builder/reset.t0000644000175000017500000000402413243466361020411 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # Test Test::Builder->reset; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder; my $Test = Test::Builder->new; my $tb = Test::Builder->create; # We'll need this later to know the outputs were reset my %Original_Output; $Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output); # Alter the state of Test::Builder as much as possible. my $output = ''; $tb->output(\$output); $tb->failure_output(\$output); $tb->todo_output(\$output); $tb->plan(tests => 14); $tb->level(0); $tb->ok(1, "Running a test to alter TB's state"); # This won't print since we just sent output off to oblivion. $tb->ok(0, "And a failure for fun"); $Test::Builder::Level = 3; $tb->exported_to('Foofer'); $tb->use_numbers(0); $tb->no_header(1); $tb->no_ending(1); $tb->done_testing; # make sure done_testing gets reset # Now reset it. $tb->reset; # Test the state of the reset builder $Test->ok( !defined $tb->exported_to, 'exported_to' ); $Test->is_eq( $tb->expected_tests, 0, 'expected_tests' ); $Test->is_eq( $tb->level, 1, 'level' ); $Test->is_eq( $tb->use_numbers, 1, 'use_numbers' ); $Test->is_eq( $tb->no_header, 0, 'no_header' ); $Test->is_eq( $tb->no_ending, 0, 'no_ending' ); $Test->is_eq( $tb->current_test, 0, 'current_test' ); $Test->is_eq( scalar $tb->summary, 0, 'summary' ); $Test->is_eq( scalar $tb->details, 0, 'details' ); $Test->is_eq( fileno $tb->output, fileno $Original_Output{output}, 'output' ); $Test->is_eq( fileno $tb->failure_output, fileno $Original_Output{failure_output}, 'failure_output' ); $Test->is_eq( fileno $tb->todo_output, fileno $Original_Output{todo_output}, 'todo_output' ); # The reset Test::Builder will take over from here. $Test->no_ending(1); $tb->current_test($Test->current_test); $tb->level(0); $tb->ok(1, 'final test to make sure output was reset'); $tb->done_testing; Test-Simple-1.302125/t/Legacy/Builder/is_fh.t0000644000175000017500000000171713243466361020365 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 11; use TieOut; ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' ); ok( !Test::Builder->is_fh(''), 'empty string' ); ok( !Test::Builder->is_fh(undef), 'undef' ); ok( open(FILE, '>foo') ); END { close FILE; 1 while unlink 'foo' } ok( Test::Builder->is_fh(*FILE) ); ok( Test::Builder->is_fh(\*FILE) ); ok( Test::Builder->is_fh(*FILE{IO}) ); tie *OUT, 'TieOut'; ok( Test::Builder->is_fh(*OUT) ); ok( Test::Builder->is_fh(\*OUT) ); SKIP: { skip "*TIED_HANDLE{IO} doesn't work in this perl", 1 unless defined *OUT{IO}; ok( Test::Builder->is_fh(*OUT{IO}) ); } package Lying::isa; sub isa { my $self = shift; my $parent = shift; return 1 if $parent eq 'IO::Handle'; } ::ok( Test::Builder->is_fh(bless {}, "Lying::isa")); Test-Simple-1.302125/t/Legacy/Builder/carp.t0000644000175000017500000000111313243466361020210 0ustar exodistexodist#!/usr/bin/perl BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 3; use Test::Builder; my $tb = Test::Builder->create; sub foo { $tb->croak("foo") } sub bar { $tb->carp("bar") } eval { foo() }; is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1; eval { $tb->croak("this") }; is $@, sprintf "this at %s line %s.\n", $0, __LINE__ - 1; { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join '', @_; }; bar(); is $warning, sprintf "bar at %s line %s.\n", $0, __LINE__ - 1; } Test-Simple-1.302125/t/Legacy/Builder/try.t0000644000175000017500000000135313243466361020107 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More 'no_plan'; require Test::Builder; my $tb = Test::Builder->new; # Test that _try() has no effect on $@ and $! and is not effected by # __DIE__ { local $SIG{__DIE__} = sub { fail("DIE handler called: @_") }; local $@ = 42; local $! = 23; is $tb->_try(sub { 2 }), 2; is $tb->_try(sub { return '' }), ''; is $tb->_try(sub { die; }), undef; is_deeply [$tb->_try(sub { die "Foo\n" })], [undef, "Foo\n"]; is $@, 42; cmp_ok $!, '==', 23; } ok !eval { $tb->_try(sub { die "Died\n" }, die_on_fail => 1); }; is $@, "Died\n"; Test-Simple-1.302125/t/Legacy/filehandles.t0000644000175000017500000000044213243466361020157 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } } use lib 't/lib'; use Test::More tests => 1; use Dev::Null; tie *STDOUT, "Dev::Null" or die $!; print "not ok 1\n"; # this should not print. pass 'STDOUT can be mucked with'; Test-Simple-1.302125/t/Legacy/check_tests.t0000644000175000017500000000460513243466361020205 0ustar exodistexodistuse strict; use Test::Tester; use Data::Dumper qw(Dumper); my $test = Test::Builder->new; $test->plan(tests => 139); my $cap; $cap = Test::Tester->capture; my @tests = ( [ 'pass', '$cap->ok(1, "pass");', { name => "pass", ok => 1, actual_ok => 1, reason => "", type => "", diag => "", depth => 0, }, ], [ 'pass diag', '$cap->ok(1, "pass diag"); $cap->diag("pass diag1"); $cap->diag("pass diag2");', { name => "pass diag", ok => 1, actual_ok => 1, reason => "", type => "", diag => "pass diag1\npass diag2\n", depth => 0, }, ], [ 'pass diag no \\n', '$cap->ok(1, "pass diag"); $cap->diag("pass diag1"); $cap->diag("pass diag2");', { name => "pass diag", ok => 1, actual_ok => 1, reason => "", type => "", diag => "pass diag1\npass diag2", depth => 0, }, ], [ 'fail', '$cap->ok(0, "fail"); $cap->diag("fail diag");', { name => "fail", ok => 0, actual_ok => 0, reason => "", type => "", diag => "fail diag\n", depth => 0, }, ], [ 'skip', '$cap->skip("just because");', { name => "", ok => 1, actual_ok => 1, reason => "just because", type => "skip", diag => "", depth => 0, }, ], [ 'todo_skip', '$cap->todo_skip("why not");', { name => "", ok => 1, actual_ok => 0, reason => "why not", type => "todo_skip", diag => "", depth => 0, }, ], [ 'pass diag qr', '$cap->ok(1, "pass diag qr"); $cap->diag("pass diag qr");', { name => "pass diag qr", ok => 1, actual_ok => 1, reason => "", type => "", diag => qr/pass diag qr/, depth => 0, }, ], [ 'fail diag qr', '$cap->ok(0, "fail diag qr"); $cap->diag("fail diag qr");', { name => "fail diag qr", ok => 0, actual_ok => 0, reason => "", type => "", diag => qr/fail diag qr/, depth => 0, }, ], ); my $big_code = ""; my @big_expect; foreach my $test (@tests) { my ($name, $code, $expect) = @$test; $big_code .= "$code\n"; push(@big_expect, $expect); my $test_sub = eval "sub {$code}"; check_test($test_sub, $expect, $name); } my $big_test_sub = eval "sub {$big_code}"; check_tests($big_test_sub, \@big_expect, "run all"); Test-Simple-1.302125/t/Legacy/subtest/0000755000175000017500000000000013243466361017205 5ustar exodistexodistTest-Simple-1.302125/t/Legacy/subtest/implicit_done.t0000644000175000017500000000073713243466361022220 0ustar exodistexodist#!/usr/bin/perl -w # A subtest without a plan implicitly calls "done_testing" use strict; use Test::More; pass "Before"; subtest 'basic' => sub { pass "Inside sub test"; }; subtest 'with done' => sub { pass 'This has done_testing'; done_testing; }; subtest 'with plan' => sub { plan tests => 1; pass 'I have a plan, Batman!'; }; subtest 'skipping' => sub { plan skip_all => 'Skipping'; fail 'Shouldnt see me!'; }; pass "After"; done_testing; Test-Simple-1.302125/t/Legacy/subtest/line_numbers.t0000644000175000017500000000742213243466361022061 0ustar exodistexodist#!/usr/bin/perl -w # Test Test::More::subtest(), focusing on correct line numbers in # failed test diagnostics. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 5; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1"); test_out(" not ok 2"); test_err(" # Failed test at $0 line $line{innerfail1}."); test_out(" ok 3"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail1}."); subtest namehere => sub { plan tests => 3; ok 1; ok 0; BEGIN{ $line{innerfail1} = __LINE__ } ok 1; }; BEGIN{ $line{outerfail1} = __LINE__ } test_test("un-named inner tests"); } { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); test_err(" # Failed test 'second is bad'"); test_err(" # at $0 line $line{innerfail2}."); test_out(" ok 3 - third is good"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail2}."); subtest namehere => sub { plan tests => 3; ok 1, "first is good"; ok 0, "second is bad"; BEGIN{ $line{innerfail2} = __LINE__ } ok 1, "third is good"; }; BEGIN{ $line{outerfail2} = __LINE__ } test_test("named inner tests"); } sub run_the_subtest { subtest namehere => sub { plan tests => 3; ok 1, "first is good"; ok 0, "second is bad"; BEGIN{ $line{innerfail3} = __LINE__ } ok 1, "third is good"; }; BEGIN{ $line{outerfail3} = __LINE__ } } { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); test_err(" # Failed test 'second is bad'"); test_err(" # at $0 line $line{innerfail3}."); test_out(" ok 3 - third is good"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail3}."); run_the_subtest(); test_test("subtest() called from a sub"); } { test_out( "# Subtest: namehere"); test_out( " 1..0"); test_err( " # No tests run!"); test_out( 'not ok 1 - No tests run for subtest "namehere"'); test_err(q{# Failed test 'No tests run for subtest "namehere"'}); test_err( "# at $0 line $line{outerfail4}."); subtest namehere => sub { done_testing; }; BEGIN{ $line{outerfail4} = __LINE__ } test_test("lineno in 'No tests run' diagnostic"); } { test_out("# Subtest: namehere"); test_out(" 1..1"); test_out(" not ok 1 - foo is bar"); test_err(" # Failed test 'foo is bar'"); test_err(" # at $0 line $line{is_fail}."); test_err(" # got: 'foo'"); test_err(" # expected: 'bar'"); test_err(" # Looks like you failed 1 test of 1."); test_out('not ok 1 - namehere'); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{is_outer_fail}."); subtest namehere => sub { plan tests => 1; is 'foo', 'bar', 'foo is bar'; BEGIN{ $line{is_fail} = __LINE__ } }; BEGIN{ $line{is_outer_fail} = __LINE__ } test_test("diag indent for is() in subtest"); } Test-Simple-1.302125/t/Legacy/subtest/for_do_t.test0000644000175000017500000000016013243466361021676 0ustar exodistexodist# Test used by t/subtest/do.t use Test::More; pass("First"); pass("Second"); pass("Third"); done_testing(3); Test-Simple-1.302125/t/Legacy/subtest/predicate.t0000644000175000017500000001135413243466361021336 0ustar exodistexodist#!/usr/bin/perl -w # Test the use of subtest() to define new test predicates that combine # multiple existing predicates. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 5; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; # Define a new test predicate with Test::More::subtest(), using # Test::More predicates as building blocks... sub foobar_ok ($;$) { my ($value, $name) = @_; $name ||= "foobar_ok"; local $Test::Builder::Level = $Test::Builder::Level + 1; subtest $name => sub { plan tests => 2; ok $value =~ /foo/, "foo"; ok $value =~ /bar/, "bar"; BEGIN{ $line{foobar_ok_bar} = __LINE__ } }; } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{foobar_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); foobar_ok "foot", "namehere"; test_test("foobar_ok failing line numbers"); } # Wrap foobar_ok() to make another new predicate... sub foobar_ok_2 ($;$) { my ($value, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; foobar_ok($value, $name); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{foobar_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); foobar_ok_2 "foot", "namehere"; test_test("foobar_ok_2 failing line numbers"); } # Define another new test predicate, this time using # Test::Builder::subtest() rather than Test::More::subtest()... sub barfoo_ok ($;$) { my ($value, $name) = @_; $name ||= "barfoo_ok"; Test::Builder->new->subtest($name => sub { plan tests => 2; ok $value =~ /foo/, "foo"; ok $value =~ /bar/, "bar"; BEGIN{ $line{barfoo_ok_bar} = __LINE__ } }); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); barfoo_ok "foot", "namehere"; test_test("barfoo_ok failing line numbers"); } # Wrap barfoo_ok() to make another new predicate... sub barfoo_ok_2 ($;$) { my ($value, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; barfoo_ok($value, $name); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); barfoo_ok_2 "foot", "namehere"; test_test("barfoo_ok_2 failing line numbers"); } # A subtest-based predicate called from within a subtest { test_out("# Subtest: outergroup"); test_out(" 1..2"); test_out(" ok 1 - this passes"); test_out(" # Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out(" not ok 2 - namehere"); test_err(" # Failed test 'namehere'"); test_err(" # at $0 line $line{ipredcall}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - outergroup"); test_err("# Failed test 'outergroup'"); test_err("# at $0 line $line{outercall}."); subtest outergroup => sub { plan tests => 2; ok 1, "this passes"; barfoo_ok_2 "foot", "namehere"; BEGIN{ $line{ipredcall} = __LINE__ } }; BEGIN{ $line{outercall} = __LINE__ } test_test("outergroup with internal barfoo_ok_2 failing line numbers"); } Test-Simple-1.302125/t/Legacy/subtest/singleton.t0000644000175000017500000000131013243466361021367 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 3; { package Test::Singleton; use Test::Builder; my $TB = Test::Builder->new; sub singleton_ok ($;$) { my( $val, $name ) = @_; $TB->ok( $val, $name ); } } ok 1, 'TB top level'; subtest 'doing a subtest' => sub { plan tests => 4; ok 1, 'first test in subtest'; Test::Singleton::singleton_ok(1, 'this should not fail'); ok 1, 'second test in subtest'; Test::Singleton::singleton_ok(1, 'this should not fail'); }; ok 1, 'left subtest'; Test-Simple-1.302125/t/Legacy/subtest/callback.t0000644000175000017500000000177013243466361021133 0ustar exodistexodist#!/usr/bin/perl -w # What happens when a subtest dies? use lib 't/lib'; use strict; use Test::More; use Test::Builder; use Test2::API; my $Test = Test::Builder->new; my $step = 0; my @callback_calls = (); Test2::API::test2_add_callback_pre_subtest( sub { $Test->is_num( $step, 0, 'pre-subtest callbacks should be invoked before the subtest', ); ++$step; push @callback_calls, [@_]; }, ); $Test->subtest( (my $subtest_name='some subtest'), (my $subtest_code=sub { $Test->is_num( $step, 1, 'subtest should be run after the pre-subtest callbacks', ); ++$step; }), (my @subtest_args = (1,2,3)), ); is_deeply( \@callback_calls, [[$subtest_name,$subtest_code,@subtest_args]], 'pre-subtest callbacks should be invoked with the expected arguments', ); $Test->is_num( $step, 2, 'the subtest should be run', ); $Test->done_testing(); Test-Simple-1.302125/t/Legacy/subtest/bail_out.t0000644000175000017500000000240013243466361021164 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } my $goto = 0; my $Exit_Code; BEGIN { *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX if $goto; CORE::exit($Exit_Code)}; } use Test::Builder; use Test::More; my $skip = ref(Test::Builder->new->{Stack}->top->format) ne 'Test::Builder::Formatter'; plan skip_all => "This test cannot be run with the current formatter" if $skip; $goto = 1; my $output; my $TB = Test::More->builder; $TB->output(\$output); my $Test = Test::Builder->create; $Test->level(0); $Test->plan(tests => 2); plan tests => 4; ok 'foo'; subtest 'bar' => sub { plan tests => 3; ok 'sub_foo'; subtest 'sub_bar' => sub { plan tests => 3; ok 'sub_sub_foo'; ok 'sub_sub_bar'; BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); ok 'sub_sub_baz'; }; ok 'sub_baz'; }; XXX: $Test->is_eq( $output, <<'OUT' ); 1..4 ok 1 # Subtest: bar 1..3 ok 1 # Subtest: sub_bar 1..3 ok 1 ok 2 Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); Test2::API::test2_stack()->top->set_no_ending(1); Test-Simple-1.302125/t/Legacy/subtest/threads.t0000644000175000017500000000065613243466361021033 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; use Test::More; subtest 'simple test with threads on' => sub { is( 1+1, 2, "simple test" ); is( "a", "a", "another simple test" ); }; pass("Parent retains sharedness"); done_testing(2); Test-Simple-1.302125/t/Legacy/subtest/events.t0000644000175000017500000000057013243466361020700 0ustar exodistexodistuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my $events = intercept { subtest foo => sub { ok(1, "pass"); }; }; my $st = $events->[-1]; isa_ok($st, 'Test2::Event::Subtest'); ok(my $id = $st->subtest_id, "got an id"); for my $se (@{$st->subevents}) { is($se->trace->hid, $id, "set subtest_id on child event"); } done_testing; Test-Simple-1.302125/t/Legacy/subtest/basic.t0000644000175000017500000001131413243466361020453 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::Builder::NoOutput; use Test::More tests => 12; # TB Methods expect to be wrapped. my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $diag = sub { shift->diag(@_) }; my $finalize = sub { shift->finalize(@_) }; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 7 ); for( 1 .. 3 ) { $tb->$ok( $_, "We're on $_" ); $tb->$diag("We ran $_"); } { my $indented = $tb->child; $indented->$plan('no_plan'); $indented->$ok( 1, "We're on 1" ); $indented->$ok( 1, "We're on 2" ); $indented->$ok( 1, "We're on 3" ); $indented->$finalize; } for( 7, 8, 9 ) { $tb->$ok( $_, "We're on $_" ); } is $tb->read, <<"END", 'Output should nest properly'; 1..7 ok 1 - We're on 1 # We ran 1 ok 2 - We're on 2 # We ran 2 ok 3 - We're on 3 # We ran 3 ok 1 - We're on 1 ok 2 - We're on 2 ok 3 - We're on 3 1..3 ok 4 - Child of $0 ok 5 - We're on 7 ok 6 - We're on 8 ok 7 - We're on 9 END } { my $tb = Test::Builder::NoOutput->create; $tb->$plan('no_plan'); for( 1 .. 1 ) { $tb->$ok( $_, "We're on $_" ); $tb->$diag("We ran $_"); } { my $indented = $tb->child; $indented->$plan('no_plan'); $indented->$ok( 1, "We're on 1" ); { my $indented2 = $indented->child('with name'); $indented2->$plan( tests => 2 ); $indented2->$ok( 1, "We're on 2.1" ); $indented2->$ok( 1, "We're on 2.1" ); $indented2->$finalize; } $indented->$ok( 1, 'after child' ); $indented->$finalize; } for(7) { $tb->$ok( $_, "We're on $_" ); } $tb->_ending; is $tb->read, <<"END", 'We should allow arbitrary nesting'; ok 1 - We're on 1 # We ran 1 ok 1 - We're on 1 1..2 ok 1 - We're on 2.1 ok 2 - We're on 2.1 ok 2 - with name ok 3 - after child 1..3 ok 2 - Child of $0 ok 3 - We're on 7 1..3 END } { #line 108 my $tb = Test::Builder::NoOutput->create; { my $child = $tb->child('expected to fail'); $child->$plan( tests => 3 ); $child->$ok(1); $child->$ok(0); $child->$ok(3); $child->$finalize; } { my $child = $tb->child('expected to pass'); $child->$plan( tests => 3 ); $child->$ok(1); $child->$ok(2); $child->$ok(3); $child->$finalize; } is $tb->read, <<"END", 'Previous child failures should not force subsequent failures'; 1..3 ok 1 not ok 2 # Failed test at $0 line 114. ok 3 # Looks like you failed 1 test of 3. not ok 1 - expected to fail # Failed test 'expected to fail' # at $0 line 116. 1..3 ok 1 ok 2 ok 3 ok 2 - expected to pass END } { my $tb = Test::Builder::NoOutput->create; my $child = $tb->child('one'); is $child->{$_}, $tb->{$_}, "The child should copy the ($_) filehandle" foreach qw{Out_FH Todo_FH Fail_FH}; $child->$finalize; } { my $tb = Test::Builder::NoOutput->create; my $child = $tb->child('one'); can_ok $child, 'parent'; can_ok $tb, 'name'; is $child->name, 'one', '... but child names should be whatever we set them to'; $child->$finalize; $child = $tb->child; $child->$finalize; } # Skip all subtests { my $tb = Test::Builder::NoOutput->create; { my $child = $tb->child('skippy says he loves you'); eval { $child->$plan( skip_all => 'cuz I said so' ) }; } subtest 'skip all', sub { plan skip_all => 'subtest with skip_all'; ok 0, 'This should never be run'; }; } # to do tests { #line 204 my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); my $child = $tb->child; $child->$plan( tests => 1 ); $child->todo_start( 'message' ); $child->$ok( 0 ); $child->todo_end; $child->$finalize; $tb->_ending; is $tb->read, <<"END", 'TODO tests should not make the parent test fail'; 1..1 1..1 not ok 1 # TODO message # Failed (TODO) test at $0 line 209. ok 1 - Child of $0 END } { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); my $child = $tb->child; $child->$finalize; $tb->_ending; my $expected = <<"END"; 1..1 not ok 1 - No tests run for subtest "Child of $0" END like $tb->read, qr/\Q$expected\E/, 'Not running subtests should make the parent test fail'; } Test-Simple-1.302125/t/Legacy/subtest/wstat.t0000644000175000017500000000056113243466361020536 0ustar exodistexodist#!/usr/bin/perl -w # Test that setting $? doesn't affect subtest success use strict; use Test::More; subtest foo => sub { plan tests => 1; $? = 1; pass('bar'); }; is $?, 1, "exit code keeps on from a subtest"; subtest foo2 => sub { plan tests => 1; pass('bar2'); $? = 1; }; is $?, 1, "exit code keeps on from a subtest"; done_testing(4); Test-Simple-1.302125/t/Legacy/subtest/plan.t0000644000175000017500000000254113243466361020326 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::Builder::NoOutput; use Test::More tests => 6; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; { ok defined &subtest, 'subtest() should be exported to our namespace'; is prototype('subtest'), undef, '... has no prototype'; subtest 'subtest with plan', sub { plan tests => 2; ok 1, 'planned subtests should work'; ok 1, '... and support more than one test'; }; subtest 'subtest without plan', sub { plan 'no_plan'; ok 1, 'no_plan subtests should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; }; subtest 'subtest with implicit done_testing()', sub { ok 1, 'subtests with an implicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; }; subtest 'subtest with explicit done_testing()', sub { ok 1, 'subtests with an explicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; done_testing(); }; } Test-Simple-1.302125/t/Legacy/subtest/todo.t0000644000175000017500000001252613243466361020345 0ustar exodistexodist#!/usr/bin/perl -w # Test todo subtests. # # A subtest in a todo context should have all of its diagnostic output # redirected to the todo output destination, but individual tests # within the subtest should not become todo tests themselves. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; # Repeat each test for various combinations of the todo reason, # the mechanism by which it is set and $Level. our @test_combos; foreach my $level (1, 2, 3) { push @test_combos, ['$TODO', 'Reason', $level], ['todo_start', 'Reason', $level], ['todo_start', '', $level], ['todo_start', 0, $level]; } plan tests => 8 * @test_combos; sub test_subtest_in_todo { my ($name, $code, $want_out, $no_tests_run) = @_; my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx'; chomp $want_out; my @outlines = split /\n/, $want_out; foreach my $combo (@test_combos) { my ($set_via, $todo_reason, $level) = @$combo; test_out( map { my $x = $_; $x =~ s/\s+$//g; $x } "# Subtest: xxx", @outlines, "not ok 1 - $xxx # TODO $todo_reason", "# Failed (TODO) test '$xxx'", "# at $0 line $line{xxx}.", "not ok 2 - regular todo test # TODO $todo_reason", "# Failed (TODO) test 'regular todo test'", "# at $0 line $line{reg}.", ); { local $TODO = $set_via eq '$TODO' ? $todo_reason : undef; if ($set_via eq 'todo_start') { Test::Builder->new->todo_start($todo_reason); } subtest_at_level( 'xxx', $code, $level); BEGIN{ $line{xxx} = __LINE__ } ok 0, 'regular todo test'; BEGIN{ $line{reg} = __LINE__ } if ($set_via eq 'todo_start') { Test::Builder->new->todo_end; } } test_test("$name ($level), todo [$todo_reason] set via $set_via"); } } package Foo; # If several stack frames are in package 'main' then $Level # could be wrong and $main::TODO might still be found. Using # another package makes the tests more sensitive. sub main::subtest_at_level { my ($name, $code, $level) = @_; if ($level > 1) { local $Test::Builder::Level = $Test::Builder::Level + 1; main::subtest_at_level($name, $code, $level-1); } else { Test::Builder->new->subtest($name => $code); } } package main; test_subtest_in_todo("plan, no tests run", sub { plan tests => 2; }, < 17; ok 0, 'failme'; BEGIN { $line{fail2} = __LINE__ } }, <new->todo_start('Inner2'); ok 0, 'failing TODO b'; BEGIN{ $line{ftb} = __LINE__ } ok 1, 'unexpected pass b'; Test::Builder->new->todo_end; ok 0, 'inner test 3'; BEGIN{ $line{in3} = __LINE__ } }, <new; $tb->ok( !eval { $tb->subtest() } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); $tb->ok( !eval { $tb->subtest("foo") } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); my $foo; $tb->subtest('Arg passing', sub { $foo = shift; $tb->ok(1); }, 'foo'); $tb->is_eq($foo, 'foo'); $tb->done_testing(); Test-Simple-1.302125/t/Legacy/subtest/fork.t0000644000175000017500000000231413243466361020333 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD use Test2::Util qw/CAN_FORK/; BEGIN { unless(CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } use IO::Pipe; use Test::Builder; use Test::More; plan 'skip_all' => "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); plan 'tests' => 1; subtest 'fork within subtest' => sub { plan tests => 2; my $pipe = IO::Pipe->new; my $pid = fork; defined $pid or plan skip_all => "Fork not working"; if ($pid) { $pipe->reader; my $child_output = do { local $/ ; <$pipe> }; waitpid $pid, 0; is $?, 0, 'child exit status'; like $child_output, qr/^[\s#]+Child Done\s*\z/, 'child output'; } else { $pipe->writer; # Force all T::B output into the pipe, for the parent # builder as well as the current subtest builder. my $tb = Test::Builder->new; $tb->output($pipe); $tb->failure_output($pipe); $tb->todo_output($pipe); diag 'Child Done'; exit 0; } }; Test-Simple-1.302125/t/Legacy/subtest/die.t0000644000175000017500000000102713243466361020133 0ustar exodistexodist#!/usr/bin/perl -w # What happens when a subtest dies? use lib 't/lib'; use strict; use Test::Builder; use Test::Builder::NoOutput; my $Test = Test::Builder->new; { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $Test->ok( !eval { $tb->subtest("death" => sub { die "Death in the subtest"; }); 1; }); $Test->like( $@, qr/^Death in the subtest at \Q$0\E line /); $Test->ok( !$tb->parent, "the parent object is restored after a die" ); } $Test->done_testing(); Test-Simple-1.302125/t/Legacy/subtest/do.t0000644000175000017500000000043313243466361017774 0ustar exodistexodist#!/usr/bin/perl -w # Test the idiom of running another test file as a subtest. use strict; use Test::More; pass("First"); my $file = "./t/Legacy/subtest/for_do_t.test"; ok -e $file, "subtest test file exists"; subtest $file => sub { do $file }; pass("Last"); done_testing(4); Test-Simple-1.302125/t/Legacy/require_ok.t0000644000175000017500000000142213243466361020045 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 8; # Symbol and Class::Struct are both non-XS core modules back to 5.004. # So they'll always be there. require_ok("Symbol"); ok( $INC{'Symbol.pm'}, "require_ok MODULE" ); require_ok("Class/Struct.pm"); ok( $INC{'Class/Struct.pm'}, "require_ok FILE" ); # Its more trouble than its worth to try to create these filepaths to test # through require_ok() so we cheat and use the internal logic. ok !Test::More::_is_module_name('foo:bar'); ok !Test::More::_is_module_name('foo/bar.thing'); ok !Test::More::_is_module_name('Foo::Bar::'); ok Test::More::_is_module_name('V'); Test-Simple-1.302125/t/Legacy/fail-more.t0000644000175000017500000002506413243466361017563 0ustar exodistexodist#!perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 80); sub like ($$;$) { $TB->like(@_); } sub is ($$;$) { $TB->is_eq(@_); } sub main::out_ok ($$) { $TB->is_eq( $out->read, shift ); $TB->is_eq( $err->read, shift ); } sub main::out_like ($$) { my($output, $failure) = @_; $TB->like( $out->read, qr/$output/ ); $TB->like( $err->read, qr/$failure/ ); } package main; require Test::More; our $TODO; my $Total = 38; Test::More->import(tests => $Total); $out->read; # clear the plan from $out # This should all work in the presence of a __DIE__ handler. local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; my $tb = Test::More->builder; $tb->use_numbers(0); my $Filename = quotemeta $0; #line 38 ok( 0, 'failing' ); out_ok( <can(...) OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' # at $0 line 197. # Mooble::Hooble::Yooble->can('this') failed # Mooble::Hooble::Yooble->can('that') failed ERR #line 208 can_ok('Mooble::Hooble::Yooble', ()); out_ok( <can(...) OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' # at $0 line 208. # can_ok() called with no methods ERR #line 218 can_ok(undef, undef); out_ok( <can(...) OUT # Failed test '->can(...)' # at $0 line 218. # can_ok() called with empty class or reference ERR #line 228 can_ok([], "foo"); out_ok( <can('foo') OUT # Failed test 'ARRAY->can('foo')' # at $0 line 228. # ARRAY->can('foo') failed ERR #line 238 isa_ok(bless([], "Foo"), "Wibble"); out_ok( <new\\(\\) died OUT # Failed test 'undef->new\\(\\) died' # at $Filename line 278. # Error was: Can't call method "new" on an undefined value at .* ERR #line 288 new_ok( "Does::Not::Exist" ); out_like( <new\\(\\) died OUT # Failed test 'Does::Not::Exist->new\\(\\) died' # at $Filename line 288. # Error was: Can't locate object method "new" via package "Does::Not::Exist" .* ERR { package Foo; sub new { } } { package Bar; sub new { {} } } { package Baz; sub new { bless {}, "Wibble" } } #line 303 new_ok( "Foo" ); out_ok( <is_eq( $out->read, <is_eq( $err->read, <create; $TB->plan(tests => 4); require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; package main; require Test::More; Test::More->import(tests => 1); { eval q{ like( "foo", qr/that/, 'is foo like that' ); }; $TB->is_eq($out->read, <like($err->read, qr/^$err_re$/, 'failing errors'); } { # line 62 like("foo", "not a regex"); $TB->is_eq($out->read, <is_eq($err->read, <summary; } Test-Simple-1.302125/t/Legacy/extra_one.t0000644000175000017500000000161613243466361017671 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 2); sub is { $TB->is_eq(@_) } package main; require Test::Simple; Test::Simple->import(tests => 1); ok(1); ok(1); ok(1); END { My::Test::is($$out, <new(); sub fake { $TEST->use_numbers(0); $TEST->no_ending(1); $TEST->done_testing(1); # a computed number of tests from its deferred magic } my $events = intercept { fake() }; is(@$events, 1, "only 1 event"); is($events->[0]->max, 1, "Plan set to 1, not 0"); done_testing; Test-Simple-1.302125/t/Legacy/Bugs/629.t0000644000175000017500000000170313243466361017122 0ustar exodistexodistuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my @warnings; intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; ok(!@warnings, "did not warn when waiting for done_testing"); intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; plan 'no_plan'; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; ok(!@warnings, "did not warn with 'no_plan'"); intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; plan tests => 1; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; is(@warnings, 1, "warned with static plan"); like( $warnings[0], qr/skip\(\) needs to know \$how_many tests are in the block/, "Got expected warning" ); done_testing; Test-Simple-1.302125/t/Legacy/fail_one.t0000644000175000017500000000155113243466361017457 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; # Normalize the output whether we're running under Test::Harness or not. local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $Test = Test::Builder->new; { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); #line 28 $tb->$ok(0); $tb->_ending; $Test->is_eq($tb->read('out'), <is_eq($tb->read('err'), <$done_testing(2); } Test-Simple-1.302125/t/Legacy/bail_out.t0000644000175000017500000000152313243466361017500 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } my $Exit_Code; BEGIN { *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; } # This test uses multiple builders, the real one is using the top hub, we need # to fix the ending. Test2::API::test2_stack()->top->set_no_ending(1); use Test::Builder; use Test::More; my $output; my $TB = Test::More->builder; $TB->output(\$output); my $Test = Test::Builder->create; $Test->level(0); $Test->plan(tests => 3); plan tests => 4; BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); $Test->is_eq( $output, <<'OUT' ); 1..4 Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); $Test->ok( $Test->can("BAILOUT"), "Backwards compat" ); Test-Simple-1.302125/t/Legacy/overload.t0000644000175000017500000000420513243466361017515 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 19; package Overloaded; use overload q{eq} => sub { $_[0]->{string} eq $_[1] }, q{==} => sub { $_[0]->{num} == $_[1] }, q{""} => sub { $_[0]->{stringify}++; $_[0]->{string} }, q{0+} => sub { $_[0]->{numify}++; $_[0]->{num} } ; sub new { my $class = shift; bless { string => shift, num => shift, stringify => 0, numify => 0, }, $class; } package main; local $SIG{__DIE__} = sub { my($call_file, $call_line) = (caller)[1,2]; fail("SIGDIE accidentally called"); diag("From $call_file at $call_line"); }; my $obj = Overloaded->new('foo', 42); isa_ok $obj, 'Overloaded'; cmp_ok $obj, 'eq', 'foo', 'cmp_ok() eq'; is $obj->{stringify}, 0, ' does not stringify'; is $obj, 'foo', 'is() with string overloading'; cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; is $obj->{numify}, 0, ' does not numify'; is_deeply [$obj], ['foo'], 'is_deeply with string overloading'; ok eq_array([$obj], ['foo']), 'eq_array ...'; ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...'; # rt.cpan.org 13506 is_deeply $obj, 'foo', 'is_deeply with string overloading at the top'; Test::More->builder->is_num($obj, 42); Test::More->builder->is_eq ($obj, "foo"); { # rt.cpan.org 14675 package TestPackage; use overload q{""} => sub { ::fail("This should not be called") }; package Foo; ::is_deeply(['TestPackage'], ['TestPackage']); ::is_deeply({'TestPackage' => 'TestPackage'}, {'TestPackage' => 'TestPackage'}); ::is_deeply('TestPackage', 'TestPackage'); } # Make sure 0 isn't a special case. [rt.cpan.org 41109] { my $obj = Overloaded->new('0', 42); isa_ok $obj, 'Overloaded'; cmp_ok $obj, 'eq', '0', 'cmp_ok() eq'; is $obj->{stringify}, 0, ' does not stringify'; is $obj, '0', 'is() with string overloading'; } Test-Simple-1.302125/t/Legacy/bad_plan.t0000644000175000017500000000075713243466361017452 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 2 ); $Test->level(0); my $tb = Test::Builder->create; eval { $tb->plan(7); }; $Test->like( $@, qr/^plan\(\) doesn't understand 7/, 'bad plan()' ) || print STDERR "# $@"; eval { $tb->plan(wibble => 7); }; $Test->like( $@, qr/^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) || print STDERR "# $@"; Test-Simple-1.302125/t/Legacy/01-basic.t0000644000175000017500000000013213243466361017174 0ustar exodistexodistuse strict; use Test::More tests => 3; use ok 'strict'; use ok 'Test::More'; use ok 'ok'; Test-Simple-1.302125/t/Legacy/run_test.t0000644000175000017500000001020713243466361017544 0ustar exodistexodistuse strict; use Test::Tester; use Data::Dumper qw(Dumper); my $test = Test::Builder->new; $test->plan(tests => 54); my $cap; { $cap = Test::Tester->capture; my ($prem, @results) = run_tests( sub {$cap->ok(1, "run pass")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run pass no prem"); $test->is_num(scalar (@results), 1, "run pass result count"); my $res = $results[0]; $test->is_eq($res->{name}, "run pass", "run pass name"); $test->is_eq($res->{ok}, 1, "run pass ok"); $test->is_eq($res->{actual_ok}, 1, "run pass actual_ok"); $test->is_eq($res->{reason}, "", "run pass reason"); $test->is_eq($res->{type}, "", "run pass type"); $test->is_eq($res->{diag}, "", "run pass diag"); $test->is_num($res->{depth}, 0, "run pass depth"); } { my ($prem, @results) = run_tests( sub {$cap->ok(0, "run fail")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run fail no prem"); $test->is_num(scalar (@results), 1, "run fail result count"); my $res = $results[0]; $test->is_eq($res->{name}, "run fail", "run fail name"); $test->is_eq($res->{actual_ok}, 0, "run fail actual_ok"); $test->is_eq($res->{ok}, 0, "run fail ok"); $test->is_eq($res->{reason}, "", "run fail reason"); $test->is_eq($res->{type}, "", "run fail type"); $test->is_eq($res->{diag}, "", "run fail diag"); $test->is_num($res->{depth}, 0, "run fail depth"); } { my ($prem, @results) = run_tests( sub {$cap->skip("just because")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "skip no prem"); $test->is_num(scalar (@results), 1, "skip result count"); my $res = $results[0]; $test->is_eq($res->{name}, "", "skip name"); $test->is_eq($res->{actual_ok}, 1, "skip actual_ok"); $test->is_eq($res->{ok}, 1, "skip ok"); $test->is_eq($res->{reason}, "just because", "skip reason"); $test->is_eq($res->{type}, "skip", "skip type"); $test->is_eq($res->{diag}, "", "skip diag"); $test->is_num($res->{depth}, 0, "skip depth"); } { my ($prem, @results) = run_tests( sub {$cap->todo_skip("just because")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "todo_skip no prem"); $test->is_num(scalar (@results), 1, "todo_skip result count"); my $res = $results[0]; $test->is_eq($res->{name}, "", "todo_skip name"); $test->is_eq($res->{actual_ok}, 0, "todo_skip actual_ok"); $test->is_eq($res->{ok}, 1, "todo_skip ok"); $test->is_eq($res->{reason}, "just because", "todo_skip reason"); $test->is_eq($res->{type}, "todo_skip", "todo_skip type"); $test->is_eq($res->{diag}, "", "todo_skip diag"); $test->is_num($res->{depth}, 0, "todo_skip depth"); } { my ($prem, @results) = run_tests( sub {$cap->diag("run diag")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "run diag\n", "run diag prem"); $test->is_num(scalar (@results), 0, "run diag result count"); } { my ($prem, @results) = run_tests( sub { $cap->ok(1, "multi pass"); $cap->diag("multi pass diag1"); $cap->diag("multi pass diag2"); $cap->ok(0, "multi fail"); $cap->diag("multi fail diag"); } ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run multi no prem"); $test->is_num(scalar (@results), 2, "run multi result count"); my $res_pass = $results[0]; $test->is_eq($res_pass->{name}, "multi pass", "run multi pass name"); $test->is_eq($res_pass->{actual_ok}, 1, "run multi pass actual_ok"); $test->is_eq($res_pass->{ok}, 1, "run multi pass ok"); $test->is_eq($res_pass->{reason}, "", "run multi pass reason"); $test->is_eq($res_pass->{type}, "", "run multi pass type"); $test->is_eq($res_pass->{diag}, "multi pass diag1\nmulti pass diag2\n", "run multi pass diag"); $test->is_num($res_pass->{depth}, 0, "run multi pass depth"); my $res_fail = $results[1]; $test->is_eq($res_fail->{name}, "multi fail", "run multi fail name"); $test->is_eq($res_pass->{actual_ok}, 1, "run multi fail actual_ok"); $test->is_eq($res_fail->{ok}, 0, "run multi fail ok"); $test->is_eq($res_pass->{reason}, "", "run multi fail reason"); $test->is_eq($res_pass->{type}, "", "run multi fail type"); $test->is_eq($res_fail->{diag}, "multi fail diag\n", "run multi fail diag"); $test->is_num($res_pass->{depth}, 0, "run multi fail depth"); } Test-Simple-1.302125/t/Legacy/plan_bad.t0000644000175000017500000000206013243466361017437 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 12; use Test::Builder; my $tb = Test::Builder->create; $tb->level(0); ok !eval { $tb->plan( tests => 'no_plan' ); }; is $@, sprintf "Number of tests must be a positive integer. You gave it 'no_plan' at %s line %d.\n", $0, __LINE__ - 1; my $foo = []; my @foo = ($foo, 2, 3); ok !eval { $tb->plan( tests => @foo ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1; ok !eval { $tb->plan( tests => 9.99 ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1; #line 25 ok !eval { $tb->plan( tests => -1 ) }; is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n"; #line 29 ok !eval { $tb->plan( tests => '' ) }; is $@, "You said to run 0 tests at $0 line 29.\n"; #line 33 ok !eval { $tb->plan( 'wibble' ) }; is $@, "plan() doesn't understand wibble at $0 line 33.\n"; Test-Simple-1.302125/t/Legacy/versions.t0000644000175000017500000000076713243466361017563 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-PRELOAD # Make sure all the modules have the same version # # TBT has its own version system. use strict; use Test::More; require Test::Builder; require Test::Builder::Module; require Test::Simple; my $dist_version = Test::More->VERSION; like( $dist_version, qr/^ \d+ \. \d+ $/x ); my @modules = qw( Test::Simple Test::Builder Test::Builder::Module ); for my $module (@modules) { is( $dist_version, $module->VERSION, $module ); } done_testing(4); Test-Simple-1.302125/t/Legacy/no_tests.t0000644000175000017500000000146713243466361017547 0ustar exodistexodist#!perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 3); package main; require Test::Simple; chdir 't'; push @INC, '../t/lib/'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 1); END { $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 255, "exit code"); $? = grep { !$_ } $TB->summary; } Test-Simple-1.302125/t/Legacy/threads.t0000644000175000017500000000115013243466361017330 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use Test::Builder; my $Test = Test::Builder->new; $Test->exported_to('main'); $Test->plan(tests => 6); for(1..5) { 'threads'->create(sub { $Test->ok(1,"Each of these should app the test number") })->join; } $Test->is_num($Test->current_test(), 5,"Should be five"); Test-Simple-1.302125/t/Legacy/skipall.t0000644000175000017500000000074113243466361017342 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More; my $Test = Test::Builder->create; $Test->plan(tests => 2); my $out = ''; my $err = ''; { my $tb = Test::More->builder; $tb->output(\$out); $tb->failure_output(\$err); plan 'skip_all'; } END { $Test->is_eq($out, "1..0 # SKIP\n"); $Test->is_eq($err, ""); } Test-Simple-1.302125/t/Legacy/missing.t0000644000175000017500000000211513243466361017351 0ustar exodistexodist# HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 2); sub is { $TB->is_eq(@_) } package main; require Test::Simple; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 5); #line 30 ok(1, 'Foo'); ok(0, 'Bar'); ok(1, '1 2 3'); END { My::Test::is($$out, < 5; can_ok "main", "explain"; is_deeply [explain("foo")], ["foo"]; is_deeply [explain("foo", "bar")], ["foo", "bar"]; # Avoid future dump formatting changes from breaking tests by just eval'ing # the dump is_deeply [map { eval $_ } explain([], {})], [[], {}]; is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99]; Test-Simple-1.302125/t/Legacy/capture.t0000644000175000017500000000075013243466361017346 0ustar exodistexodistuse strict; use Test::Tester; my $Test = Test::Builder->new; $Test->plan(tests => 3); my $cap; $cap = Test::Tester->capture; { no warnings 'redefine'; sub Test::Tester::find_run_tests { return 0}; } local $Test::Builder::Level = 0; { my $cur = $cap->current_test; $Test->is_num($cur, 0, "current test"); eval {$cap->current_test(2)}; $Test->ok($@, "can't set test_num"); } { $cap->ok(1, "a test"); my @res = $cap->details; $Test->is_num(scalar @res, 1, "res count"); } Test-Simple-1.302125/t/Legacy/no_plan.t0000644000175000017500000000151013243466361017324 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More tests => 7; my $tb = Test::Builder->create; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; #line 20 ok !eval { $tb->$plan(tests => undef) }; is($@, "Got an undefined number of tests at $0 line 20.\n"); #line 24 ok !eval { $tb->$plan(tests => 0) }; is($@, "You said to run 0 tests at $0 line 24.\n"); { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join '', @_ }; #line 31 ok $tb->$plan(no_plan => 1); is( $warning, "no_plan takes no arguments at $0 line 31.\n" ); is $tb->has_plan, 'no_plan'; } Test-Simple-1.302125/t/Legacy/simple.t0000644000175000017500000000031013243466361017164 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; BEGIN { $| = 1; $^W = 1; } use Test::Simple tests => 3; ok(1, 'compile'); ok(1); ok(1, 'foo'); Test-Simple-1.302125/t/Legacy/buffer.t0000644000175000017500000000067413243466361017161 0ustar exodistexodist#!/usr/bin/perl # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Ensure that intermixed prints to STDOUT and tests come out in the # right order (ie. no buffering problems). use Test::More tests => 20; my $T = Test::Builder->new; $T->no_ending(1); for my $num (1..10) { $tnum = $num * 2; pass("I'm ok"); $T->current_test($tnum); print "ok $tnum - You're ok\n"; } Test-Simple-1.302125/t/Legacy/new_ok.t0000644000175000017500000000130113243466361017156 0ustar exodistexodist#!/usr/bin/perl -w use strict; use Test::More tests => 13; { package Bar; sub new { my $class = shift; return bless {@_}, $class; } package Foo; our @ISA = qw(Bar); } { my $obj = new_ok("Foo"); is_deeply $obj, {}; isa_ok $obj, "Foo"; $obj = new_ok("Bar"); is_deeply $obj, {}; isa_ok $obj, "Bar"; $obj = new_ok("Foo", [this => 42]); is_deeply $obj, { this => 42 }; isa_ok $obj, "Foo"; $obj = new_ok("Foo", [], "Foo"); is_deeply $obj, {}; isa_ok $obj, "Foo"; } # And what if we give it nothing? eval { new_ok(); }; is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; Test-Simple-1.302125/t/Legacy/cmp_ok.t0000644000175000017500000000340213243466361017150 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; require Test::Builder; my $TB = Test::Builder->create; $TB->level(0); sub try_cmp_ok { my($left, $cmp, $right, $error) = @_; my %expect; if( $error ) { $expect{ok} = 0; $expect{error} = $error; } else { $expect{ok} = eval "\$left $cmp \$right"; $expect{error} = $@; $expect{error} =~ s/ at .*\n?//; } local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok; eval { $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); }; $TB->is_num(!!$ok, !!$expect{ok}, " right return"); my $diag = $err->read; if ($@) { $diag = $@; $diag =~ s/ at .*\n?//; } if( !$ok and $expect{error} ) { $diag =~ s/^# //mg; $TB->like( $diag, qr/\Q$expect{error}\E/, " expected error" ); } elsif( $ok ) { $TB->is_eq( $diag, '', " passed without diagnostic" ); } else { $TB->ok(1, " failed without diagnostic"); } } use Test::More; Test::More->builder->no_ending(1); require MyOverload; my $cmp = Overloaded::Compare->new("foo", 42); my $ify = Overloaded::Ify->new("bar", 23); my @Tests = ( [1, '==', 1], [1, '==', 2], ["a", "eq", "b"], ["a", "eq", "a"], [1, "+", 1], [1, "-", 1], [$cmp, '==', 42], [$cmp, 'eq', "foo"], [$ify, 'eq', "bar"], [$ify, "==", 23], [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], ); plan tests => scalar @Tests; $TB->plan(tests => @Tests * 2); for my $test (@Tests) { try_cmp_ok(@$test); } Test-Simple-1.302125/t/Legacy/strays.t0000644000175000017500000000074013243466361017227 0ustar exodistexodist#!/usr/bin/perl -w # Check that stray newlines in test output are properly handed. BEGIN { print "1..0 # Skip not completed\n"; exit 0; } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; $tb->ok(1, "name\n"); $tb->ok(0, "foo\nbar\nbaz"); $tb->skip("\nmoofer"); $tb->todo_skip("foo\n\n"); Test-Simple-1.302125/t/Legacy/useing.t0000644000175000017500000000055513243466361017200 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 5; require_ok('Test::Builder'); require_ok("Test::More"); require_ok("Test::Simple"); { package Foo; use Test::More import => [qw(ok is can_ok)]; can_ok('Foo', qw(ok is can_ok)); ok( !Foo->can('like'), 'import working properly' ); } Test-Simple-1.302125/t/Legacy/import.t0000644000175000017500000000036413243466361017216 0ustar exodistexodistBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 2, import => [qw(!fail)]; can_ok(__PACKAGE__, qw(ok pass like isa_ok)); ok( !__PACKAGE__->can('fail'), 'fail() not exported' ); Test-Simple-1.302125/t/Legacy/eq_set.t0000644000175000017500000000106213243466361017160 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use strict; use Test::More; plan tests => 4; # RT 3747 ok( eq_set([1, 2, [3]], [[3], 1, 2]) ); ok( eq_set([1,2,[3]], [1,[3],2]) ); # bugs.perl.org 36354 my $ref = \2; ok( eq_set( [$ref, "$ref", "$ref", $ref], ["$ref", $ref, $ref, "$ref"] ) ); TODO: { local $TODO = q[eq_set() doesn't really handle references]; ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) ); } Test-Simple-1.302125/t/Legacy/use_ok.t0000644000175000017500000000445113243466361017172 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More; note "Basic use_ok"; { package Foo::one; ::use_ok("Symbol"); ::ok( defined &gensym, 'use_ok() no args exports defaults' ); } note "With one arg"; { package Foo::two; ::use_ok("Symbol", qw(qualify)); ::ok( !defined &gensym, ' one arg, defaults overridden' ); ::ok( defined &qualify, ' right function exported' ); } note "Multiple args"; { package Foo::three; ::use_ok("Symbol", qw(gensym ungensym)); ::ok( defined &gensym && defined &ungensym, ' multiple args' ); } note "Defining constants"; { package Foo::four; my $warn; local $SIG{__WARN__} = sub { $warn .= shift; }; ::use_ok("constant", qw(foo bar)); ::ok( defined &foo, 'constant' ); ::is( $warn, undef, 'no warning'); } note "use Module VERSION"; { package Foo::five; ::use_ok("Symbol", 1.02); } note "use Module VERSION does not call import"; { package Foo::six; ::use_ok("NoExporter", 1.02); } { package Foo::seven; local $SIG{__WARN__} = sub { # Old perls will warn on X.YY_ZZ style versions. Not our problem warn @_ unless $_[0] =~ /^Argument "\d+\.\d+_\d+" isn't numeric/; }; ::use_ok("Test::More", 0.47); } note "Signals are preserved"; { package Foo::eight; local $SIG{__DIE__}; ::use_ok("SigDie"); ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); } note "Line numbers preserved"; { my $package = "that_cares_about_line_numbers"; # Store the output of caller. my @caller; { package that_cares_about_line_numbers; sub import { @caller = caller; return; } $INC{"$package.pm"} = 1; # fool use into thinking it's already loaded } ::use_ok($package); my $line = __LINE__-1; ::is( $caller[0], __PACKAGE__, "caller package preserved" ); ::is( $caller[1], __FILE__, " file" ); ::is( $caller[2], $line, " line" ); } note "not confused by functions vs class names"; { $INC{"ok.pm"} = 1; use_ok("ok"); # ok is a function inside Test::More $INC{"Foo/bar.pm"} = 1; sub Foo::bar { 42 } use_ok("Foo::bar"); # Confusing a class name with a function name } done_testing; Test-Simple-1.302125/t/Legacy/c_flag.t0000644000175000017500000000071213243466361017114 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD # Test::More should not print anything when Perl is only doing # a compile as with the -c flag or B::Deparse or perlcc. # HARNESS_ACTIVE=1 was causing an error with -c { local $ENV{HARNESS_ACTIVE} = 1; local $^C = 1; require Test::More; Test::More->import(tests => 1); fail("This should not show up"); } Test::More->builder->no_ending(1); print "1..1\n"; print "ok 1\n"; Test-Simple-1.302125/t/Legacy/undef.t0000644000175000017500000000372113243466361017005 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-FORK BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 21; BEGIN { $^W = 1; } my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; my $TB = Test::Builder->new; sub no_warnings { $TB->is_eq($warnings, '', ' no warnings'); $warnings = ''; } sub warnings_is { $TB->is_eq($warnings, $_[0]); $warnings = ''; } sub warnings_like { $TB->like($warnings, $_[0]); $warnings = ''; } my $Filename = quotemeta $0; is( undef, undef, 'undef is undef'); no_warnings; isnt( undef, 'foo', 'undef isnt foo'); no_warnings; isnt( undef, '', 'undef isnt an empty string' ); isnt( undef, 0, 'undef isnt zero' ); Test::More->builder->is_num(undef, undef, 'is_num()'); Test::More->builder->isnt_num(23, undef, 'isnt_num()'); #line 45 like( undef, qr/.*/, 'undef is like anything' ); no_warnings; eq_array( [undef, undef], [undef, 23] ); no_warnings; eq_hash ( { foo => undef, bar => undef }, { foo => undef, bar => 23 } ); no_warnings; eq_set ( [undef, undef, 12], [29, undef, undef] ); no_warnings; eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, { foo => undef, bar => { baz => undef, moo => 23 } } ); no_warnings; #line 74 cmp_ok( undef, '<=', 2, ' undef <= 2' ); warnings_like(qr/Use of uninitialized value.* at \(eval in cmp_ok\) $Filename line 74\.\n/); my $tb = Test::More->builder; SKIP: { skip("Test cannot be run with this formatter", 2) unless $tb->{Stack}->top->format->isa('Test::Builder::Formatter'); my $err = ''; $tb->failure_output(\$err); diag(undef); $tb->reset_outputs; is( $err, "# undef\n" ); no_warnings; } $tb->maybe_regex(undef); no_warnings; # test-more.googlecode.com #42 { is_deeply([ undef ], [ undef ]); no_warnings; } Test-Simple-1.302125/t/Legacy/extra.t0000644000175000017500000000216213243466361017025 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } else { unshift @INC, 't/lib'; } } use strict; use Test::Builder; use Test::Builder::NoOutput; use Test::Simple; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $TB = Test::Builder->new; my $test = Test::Builder::NoOutput->create; $test->$plan( tests => 3 ); local $ENV{HARNESS_ACTIVE} = 0; $test->$ok(1, 'Foo'); $TB->is_eq($test->read(), <$ok(0, 'Bar'); $TB->is_eq($test->read(), <$ok(1, 'Yar'); $test->$ok(1, 'Car'); $TB->is_eq($test->read(), <$ok(0, 'Sar'); $TB->is_eq($test->read(), <_ending(); $TB->is_eq($test->read(), <$done_testing(5); Test-Simple-1.302125/t/Legacy/depth.t0000644000175000017500000000057713243466361017016 0ustar exodistexodistuse strict; use warnings; use lib 't/lib'; use Test::Tester; use MyTest; my $test = Test::Builder->new; $test->plan(tests => 2); sub deeper { MyTest::ok(1); } { my @results = run_tests( sub { MyTest::ok(1); deeper(); } ); local $Test::Builder::Level = 0; $test->is_num($results[1]->{depth}, 1, "depth 1"); $test->is_num($results[2]->{depth}, 2, "deeper"); } Test-Simple-1.302125/t/Legacy/exit.t0000644000175000017500000000625213243466361016657 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # Can't use Test.pm, that's a 5.005 thing. package My::Test; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } require Test::Builder; my $TB = Test::Builder->create(); $TB->level(0); package main; use Cwd; use File::Spec; my $Orig_Dir = cwd; my $Perl = File::Spec->rel2abs($^X); if( $^O eq 'VMS' ) { # VMS can't use its own $^X in a system call until almost 5.8 $Perl = "MCR $^X" if $] < 5.007003; # Quiet noisy 'SYS$ABORT' $Perl .= q{ -"I../lib"} if $ENV{PERL_CORE}; $Perl .= q{ -"Mvmsish=hushed"}; } else { $Perl = qq("$Perl"); # protect from shell if spaces } eval { require POSIX; &POSIX::WEXITSTATUS(0) }; if( $@ ) { *exitstatus = sub { $_[0] >> 8 }; } else { *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } } # Some OS' will alter the exit code to their own native sense... # sometimes. Rather than deal with the exception we'll just # build up the mapping. print "# Building up a map of exit codes. May take a while.\n"; my %Exit_Map; open my $fh, ">", "exit_map_test" or die $!; print $fh <<'DONE'; if ($^O eq 'VMS') { require vmsish; import vmsish qw(hushed); } my $exit = shift; print "exit $exit\n"; END { $? = $exit }; DONE close $fh; END { 1 while unlink "exit_map_test" } for my $exit (0..255) { # This correctly emulates Test::Builder's behavior. my $out = qx[$Perl exit_map_test $exit]; $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" ); $Exit_Map{$exit} = exitstatus($?); } print "# Done.\n"; my %Tests = ( # File Exit Code 'success.plx' => 0, 'one_fail.plx' => 1, 'two_fail.plx' => 2, 'five_fail.plx' => 5, 'extras.plx' => 2, 'too_few.plx' => 255, 'too_few_fail.plx' => 2, 'death.plx' => 255, 'last_minute_death.plx' => 255, 'pre_plan_death.plx' => 'not zero', 'death_in_eval.plx' => 0, 'require.plx' => 0, 'death_with_handler.plx' => 255, 'exit.plx' => 1, 'one_fail_without_plan.plx' => 1, 'missing_done_testing.plx' => 254, ); chdir 't'; my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); while( my($test_name, $exit_code) = each %Tests ) { my $file = File::Spec->catfile($lib, $test_name); my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); my $actual_exit = exitstatus($wait_stat); if( $exit_code eq 'not zero' ) { $TB->isnt_num( $actual_exit, $Exit_Map{0}, "$test_name exited with $actual_exit ". "(expected non-zero)"); } else { $TB->is_num( $actual_exit, $Exit_Map{$exit_code}, "$test_name exited with $actual_exit ". "(expected $Exit_Map{$exit_code})"); } } $TB->done_testing( scalar keys(%Tests) + 256 ); # So any END block file cleanup works. chdir $Orig_Dir; Test-Simple-1.302125/t/Legacy/More.t0000644000175000017500000001214213243466361016603 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = qw(../lib ../lib/Test/Simple/t/lib); } } use lib 't/lib'; use Test::More tests => 54; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; my $Errno = 42; $@ = $Err; $! = $Errno; use_ok('Dummy'); is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' ); require_ok('Test::More'); ok( 2 eq 2, 'two is two is two is two' ); is( "foo", "foo", 'foo is foo' ); isnt( "foo", "bar", 'foo isnt bar'); isn't("foo", "bar", 'foo isn\'t bar'); #'# like("fooble", '/^foo/', 'foo is like fooble'); like("FooBle", '/foo/i', 'foo is like FooBle'); like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' ); unlike("fbar", '/^bar/', 'unlike bar'); unlike("FooBle", '/foo/', 'foo is unlike FooBle'); unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' ); my @foo = qw(foo bar baz); unlike(@foo, '/foo/'); can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); isa_ok(bless([], "Foo"), "Foo"); isa_ok([], 'ARRAY'); isa_ok(\42, 'SCALAR'); { local %Bar::; local @Foo::ISA = 'Bar'; isa_ok( "Foo", "Bar" ); } # can_ok() & isa_ok should call can() & isa() on the given object, not # just class, in case of custom can() { local *Foo::can; local *Foo::isa; *Foo::can = sub { $_[0]->[0] }; *Foo::isa = sub { $_[0]->[0] }; my $foo = bless([0], 'Foo'); ok( ! $foo->can('bar') ); ok( ! $foo->isa('bar') ); $foo->[0] = 1; can_ok( $foo, 'blah'); isa_ok( $foo, 'blah'); } pass('pass() passed'); ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), 'eq_array with simple arrays' ); is @Test::More::Data_Stack, 0, '@Data_Stack not holding onto things'; ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}), 'eq_hash with simple hashes' ); is @Test::More::Data_Stack, 0; ok( eq_set([qw(this that whatever)], [qw(that whatever this)]), 'eq_set with simple sets' ); is @Test::More::Data_Stack, 0; my @complex_array1 = ( [qw(this that whatever)], {foo => 23, bar => 42}, "moo", "yarrow", [qw(498 10 29)], ); my @complex_array2 = ( [qw(this that whatever)], {foo => 23, bar => 42}, "moo", "yarrow", [qw(498 10 29)], ); is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' ); ok( eq_array(\@complex_array1, \@complex_array2), 'eq_array with complicated arrays' ); ok( eq_set(\@complex_array1, \@complex_array2), 'eq_set with complicated arrays' ); my @array1 = (qw(this that whatever), {foo => 23, bar => 42} ); my @array2 = (qw(this that whatever), {foo => 24, bar => 42} ); ok( !eq_array(\@array1, \@array2), 'eq_array with slightly different complicated arrays' ); is @Test::More::Data_Stack, 0; ok( !eq_set(\@array1, \@array2), 'eq_set with slightly different complicated arrays' ); is @Test::More::Data_Stack, 0; my %hash1 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); my %hash2 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' ); ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes'); %hash1 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); %hash2 = ( foo => 23, bar => [qw(this tha whatever)], har => { foo => 24, bar => 42 }, ); ok( !eq_hash(\%hash1, \%hash2), 'eq_hash with slightly different complicated hashes' ); is @Test::More::Data_Stack, 0; is( Test::Builder->new, Test::More->builder, 'builder()' ); cmp_ok(42, '==', 42, 'cmp_ok =='); cmp_ok('foo', 'eq', 'foo', ' eq'); cmp_ok(42.5, '<', 42.6, ' <'); cmp_ok(0, '||', 1, ' ||'); # Piers pointed out sometimes people override isa(). { package Wibble; sub isa { my($self, $class) = @_; return 1 if $class eq 'Wibblemeister'; } sub new { bless {} } } isa_ok( Wibble->new, 'Wibblemeister' ); my $sub = sub {}; is_deeply( $sub, $sub, 'the same function ref' ); use Symbol; my $glob = gensym; is_deeply( $glob, $glob, 'the same glob' ); is_deeply( { foo => $sub, bar => [1, $glob] }, { foo => $sub, bar => [1, $glob] } ); # rt.cpan.org 53469 is_deeply with regexes is_deeply( qr/a/, qr/a/, "same regex" ); # These two tests must remain at the end. is( $@, $Err, '$@ untouched' ); cmp_ok( $!, '==', $Errno, '$! untouched' ); Test-Simple-1.302125/t/Legacy/auto.t0000644000175000017500000000112613243466361016651 0ustar exodistexodistuse strict; use warnings; use lib 't/lib'; use Test::Tester tests => 6; use SmallTest; use MyTest; { my ($prem, @results) = run_tests( sub { MyTest::ok(1, "run pass")} ); is_eq($results[0]->{name}, "run pass"); is_num($results[0]->{ok}, 1); } { my ($prem, @results) = run_tests( sub { MyTest::ok(0, "run fail")} ); is_eq($results[0]->{name}, "run fail"); is_num($results[0]->{ok}, 0); } is_eq(ref(SmallTest::getTest()), "Test::Tester::Delegate"); is_eq( SmallTest::getTest()->can('ok'), Test::Builder->can('ok'), "Delegate->can() returns the sub from the inner object", ); Test-Simple-1.302125/t/Legacy/note.t0000644000175000017500000000064013243466361016646 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::Builder::NoOutput; use Test::More tests => 2; { my $tb = Test::Builder::NoOutput->create; $tb->note("foo"); $tb->reset_outputs; is $tb->read('out'), "# foo\n"; is $tb->read('err'), ''; } Test-Simple-1.302125/t/Legacy/plan.t0000644000175000017500000000073213243466361016635 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan tests => 4; eval { plan tests => 4 }; is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ - 1), 'disallow double plan' ); eval { plan 'no_plan' }; is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ -1), 'disallow changing plan' ); pass('Just testing plan()'); pass('Testing it some more'); Test-Simple-1.302125/t/Legacy/diag.t0000644000175000017500000000262013243466361016605 0ustar exodistexodist#!perl -w use strict; use Test2::Util qw/CAN_THREAD/; # Turn on threads here, if available, since this test tends to find # lots of threading bugs. BEGIN { if (CAN_THREAD) { require threads; threads->import; } } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder::NoOutput; use Test::More tests => 7; my $test = Test::Builder::NoOutput->create; # Test diag() goes to todo_output() in a todo test. { $test->todo_start(); $test->diag("a single line"); is( $test->read('todo'), <<'DIAG', 'diag() with todo_output set' ); # a single line DIAG my $ret = $test->diag("multiple\n", "lines"); is( $test->read('todo'), <<'DIAG', ' multi line' ); # multiple # lines DIAG ok( !$ret, 'diag returns false' ); $test->todo_end(); } # Test diagnostic formatting { $test->diag("# foo"); is( $test->read('err'), "# # foo\n", "diag() adds # even if there's one already" ); $test->diag("foo\n\nbar"); is( $test->read('err'), <<'DIAG', " blank lines get escaped" ); # foo # # bar DIAG $test->diag("foo\n\nbar\n\n"); is( $test->read('err'), <<'DIAG', " even at the end" ); # foo # # bar # DIAG } # [rt.cpan.org 8392] diag(@list) emulates print { $test->diag(qw(one two)); is( $test->read('err'), <<'DIAG' ); # onetwo DIAG } Test-Simple-1.302125/t/Legacy/skip.t0000644000175000017500000000365513243466361016660 0ustar exodistexodist#!perl -w # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 17; # If we skip with the same name, Test::Harness will report it back and # we won't get lots of false bug reports. my $Why = "Just testing the skip interface."; SKIP: { skip $Why, 2 unless Pigs->can('fly'); my $pig = Pigs->new; $pig->takeoff; ok( $pig->altitude > 0, 'Pig is airborne' ); ok( $pig->airspeed > 0, ' and moving' ); } SKIP: { skip "We're not skipping", 2 if 0; pass("Inside skip block"); pass("Another inside"); } SKIP: { skip "Again, not skipping", 2 if 0; my($pack, $file, $line) = caller; is( $pack || '', '', 'calling package not interfered with' ); is( $file || '', '', ' or file' ); is( $line || '', '', ' or line' ); } SKIP: { skip $Why, 2 if 1; die "A horrible death"; fail("Deliberate failure"); fail("And again"); } { my $warning; local $SIG{__WARN__} = sub { $warning = join "", @_ }; SKIP: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; #line 56 skip $Why; fail("So very failed"); } is( $warning, "skip() needs to know \$how_many tests are in the ". "block at $0 line 56\n", 'skip without $how_many warning' ); } SKIP: { skip "Not skipping here.", 4 if 0; pass("This is supposed to run"); # Testing out nested skips. SKIP: { skip $Why, 2; fail("AHHH!"); fail("You're a failure"); } pass("This is supposed to run, too"); } { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join "", @_ }; SKIP: { skip 1, "This is backwards" if 1; pass "This does not run"; } like $warning, qr/^skip\(\) was passed a non-numeric number of tests/; } Test-Simple-1.302125/t/Legacy/utf8.t0000644000175000017500000000276313243466361016577 0ustar exodistexodist#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use warnings; my $have_perlio; BEGIN { # All together so Test::More sees the open discipline $have_perlio = eval q[ require PerlIO; PerlIO->VERSION(1.02); # required for PerlIO::get_layers binmode *STDOUT, ":encoding(utf8)"; binmode *STDERR, ":encoding(utf8)"; require Test::More; 1; ]; } use Test::More; unless (Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter')) { plan skip_all => 'Test cannot be run using this formatter'; } if( !$have_perlio ) { plan skip_all => "Don't have PerlIO 1.02"; } else { plan tests => 5; } SKIP: { skip( "Need PerlIO for this feature", 3 ) unless $have_perlio; my %handles = ( output => \*STDOUT, failure_output => \*STDERR, todo_output => \*STDOUT ); for my $method (keys %handles) { my $src = $handles{$method}; my $dest = Test::More->builder->$method; is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) }, { map { $_ => 1 } PerlIO::get_layers($src) }, "layers copied to $method"; } } # Test utf8 is ok. { my $uni = "\x{11e}"; my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; }; is( $uni, $uni, "Testing $uni" ); is_deeply( \@warnings, [] ); } Test-Simple-1.302125/t/Legacy/todo.t0000644000175000017500000000644013243466361016652 0ustar exodistexodist#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan tests => 36; $Why = 'Just testing the todo interface.'; my $is_todo; TODO: { local $TODO = $Why; fail("Expected failure"); fail("Another expected failure"); $is_todo = Test::More->builder->todo; } pass("This is not todo"); ok( $is_todo, 'TB->todo' ); TODO: { local $TODO = $Why; fail("Yet another failure"); } pass("This is still not todo"); TODO: { local $TODO = "testing that error messages don't leak out of todo"; ok( 'this' eq 'that', 'ok' ); like( 'this', qr/that/, 'like' ); is( 'this', 'that', 'is' ); isnt( 'this', 'this', 'isnt' ); can_ok('Fooble', 'yarble'); isa_ok('Fooble', 'yarble'); use_ok('Fooble'); require_ok('Fooble'); } TODO: { todo_skip "Just testing todo_skip", 2; fail("Just testing todo"); die "todo_skip should prevent this"; pass("Again"); } { my $warning; local $SIG{__WARN__} = sub { $warning = join "", @_ }; TODO: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; #line 74 todo_skip "Just testing todo_skip"; fail("So very failed"); } is( $warning, "todo_skip() needs to know \$how_many tests are in the ". "block at $0 line 74\n", 'todo_skip without $how_many warning' ); } my $builder = Test::More->builder; my $exported_to = $builder->exported_to; TODO: { $builder->exported_to("Wibble"); local $TODO = "testing \$TODO with an incorrect exported_to()"; fail("Just testing todo"); } $builder->exported_to($exported_to); $builder->todo_start('Expected failures'); fail('Testing todo_start()'); ok 0, 'Testing todo_start() with more than one failure'; $is_todo = $builder->todo; $builder->todo_end; is $is_todo, 'Expected failures', 'todo_start should have the correct TODO message'; ok 1, 'todo_end() should not leak TODO behavior'; my @nested_todo; my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' ); TODO: { local $TODO = 'Nesting TODO'; fail('fail 1'); $builder->todo_start($level1); fail('fail 2'); push @nested_todo => $builder->todo; $builder->todo_start($level2); fail('fail 3'); push @nested_todo => $builder->todo; $builder->todo_end; fail('fail 4'); push @nested_todo => $builder->todo; $builder->todo_end; $is_todo = $builder->todo; fail('fail 4'); } is_deeply \@nested_todo, [ $level1, $level2, $level1 ], 'Nested TODO message should be correct'; is $is_todo, 'Nesting TODO', '... and original TODO message should be correct'; { $builder->todo_start; fail("testing todo_start() with no message"); my $reason = $builder->todo; my $in_todo = $builder->in_todo; $builder->todo_end; is $reason, '', " todo() reports no reason"; ok $in_todo, " but we're in_todo()"; } eval { $builder->todo_end; }; is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 3; { my($reason, $in_todo); TODO: { local $TODO = ''; $reason = $builder->todo; $in_todo = $builder->in_todo; } is $reason, ''; ok !$in_todo, '$TODO = "" is not considered TODO'; } Test-Simple-1.302125/t/Legacy/fork.t0000644000175000017500000000071013243466361016640 0ustar exodistexodist#!/usr/bin/perl -w use strict; use warnings; use Test2::Util qw/CAN_FORK/; BEGIN { unless(CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan tests => 1; if( fork ) { # parent pass("Only the parent should process the ending, not the child"); } else { exit; # child } Test-Simple-1.302125/t/Legacy/fail.t0000644000175000017500000000233613243466361016620 0ustar exodistexodist#!perl -w # Simple test of what failure output looks like BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; # Normalize the output whether we're running under Test::Harness or not. local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $Test = Test::Builder->new; # Set up a builder to record some failing tests. { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 5 ); #line 28 $tb->$ok( 1, 'passing' ); $tb->$ok( 2, 'passing still' ); $tb->$ok( 3, 'still passing' ); $tb->$ok( 0, 'oh no!' ); $tb->$ok( 0, 'damnit' ); $tb->_ending; $Test->is_eq($tb->read('out'), <is_eq($tb->read('err'), <$done_testing(2); } Test-Simple-1.302125/t/Legacy/died.t0000644000175000017500000000157113243466361016612 0ustar exodistexodist#!perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 3); package main; require Test::Simple; chdir 't'; push @INC, '../t/lib/'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 1); exit 250; END { $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 250, "exit code"); $? = grep { !$_ } $TB->summary; } Test-Simple-1.302125/t/lib/0000755000175000017500000000000013243466361015056 5ustar exodistexodistTest-Simple-1.302125/t/lib/Test/0000755000175000017500000000000013243466361015775 5ustar exodistexodistTest-Simple-1.302125/t/lib/Test/Builder/0000755000175000017500000000000013243466361017363 5ustar exodistexodistTest-Simple-1.302125/t/lib/Test/Builder/NoOutput.pm0000644000175000017500000000471713243466361021527 0ustar exodistexodistpackage Test::Builder::NoOutput; use strict; use warnings; use Symbol qw(gensym); use base qw(Test::Builder); =head1 NAME Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing =head1 SYNOPSIS use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->new; ...test as normal... my $output = $tb->read; =head1 DESCRIPTION This is a subclass of Test::Builder which traps all its output. It is mostly useful for testing Test::Builder. =head3 read my $all_output = $tb->read; my $output = $tb->read($stream); Returns all the output (including failure and todo output) collected so far. It is destructive, each call to read clears the output buffer. If $stream is given it will return just the output from that stream. $stream's are... out output() err failure_output() todo todo_output() all all outputs Defaults to 'all'. =cut my $Test = __PACKAGE__->new; sub create { my $class = shift; my $self = $class->SUPER::create(@_); require Test::Builder::Formatter; $self->{Stack}->top->format(Test::Builder::Formatter->new); my %outputs = ( all => '', out => '', err => '', todo => '', ); $self->{_outputs} = \%outputs; my($out, $err, $todo) = map { gensym() } 1..3; tie *$out, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out}; tie *$err, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err}; tie *$todo, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo}; $self->output($out); $self->failure_output($err); $self->todo_output($todo); return $self; } sub read { my $self = shift; my $stream = @_ ? shift : 'all'; my $out = $self->{_outputs}{$stream}; $self->{_outputs}{$stream} = ''; # Clear all the streams if 'all' is read. if( $stream eq 'all' ) { my @keys = keys %{$self->{_outputs}}; $self->{_outputs}{$_} = '' for @keys; } return $out; } package Test::Builder::NoOutput::Tee; # A cheap implementation of IO::Tee. sub TIEHANDLE { my($class, @refs) = @_; my @fhs; for my $ref (@refs) { my $fh = Test::Builder->_new_fh($ref); push @fhs, $fh; } my $self = [@fhs]; return bless $self, $class; } sub PRINT { my $self = shift; print $_ @_ for @$self; } sub PRINTF { my $self = shift; my $format = shift; printf $_ @_ for @$self; } 1; Test-Simple-1.302125/t/lib/Test/Simple/0000755000175000017500000000000013243466361017226 5ustar exodistexodistTest-Simple-1.302125/t/lib/Test/Simple/sample_tests/0000755000175000017500000000000013243466361021731 5ustar exodistexodistTest-Simple-1.302125/t/lib/Test/Simple/sample_tests/one_fail_without_plan.plx0000644000175000017500000000023013243466361027022 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(); ok(0); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/missing_done_testing.plx0000644000175000017500000000023013243466361026664 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(); ok(1); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/death_with_handler.plx0000644000175000017500000000053013243466361026271 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 2); # Test we still get the right exit code despite having a die # handler. $SIG{__DIE__} = sub {}; require Dev::Null; tie *STDERR, 'Dev::Null'; ok(1); ok(1); $! = 0; die "This is a test"; Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/last_minute_death.plx0000644000175000017500000000041413243466361026146 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); require Dev::Null; tie *STDERR, 'Dev::Null'; ok(1); ok(1); ok(1); ok(1); ok(1); $! = 0; die "This is a test"; Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/pre_plan_death.plx0000644000175000017500000000044113243466361025422 0ustar exodistexodist# ID 20020716.013, the exit code would become 0 if the test died # before a plan. require Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); close STDERR; die "Knife?"; Test::Simple->import(tests => 3); ok(1); ok(1); ok(1); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/death_in_eval.plx0000644000175000017500000000043013243466361025235 0ustar exodistexodistrequire Test::Simple; use Carp; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); ok(1); eval { die "Foo"; }; ok(1); eval "die 'Bar'"; ok(1); eval { croak "Moo"; }; Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/too_few_fail.plx0000644000175000017500000000026213243466361025113 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(1); ok(0); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/five_fail.plx0000644000175000017500000000027513243466361024406 0ustar exodistexodistrequire Test::Simple; use lib 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(0); ok(''); ok(0); ok(0); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/two_fail.plx0000644000175000017500000000030013243466361024253 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(1); ok(1); ok(0); ok(1); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/one_fail.plx0000644000175000017500000000030013243466361024223 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(2); ok(0); ok(1); ok(2); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/too_few.plx0000644000175000017500000000025313243466361024120 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/success.plx0000644000175000017500000000033713243466361024131 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(5, 'yep'); ok(3, 'beer'); ok("wibble", "wibble"); ok(1); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/require.plx0000644000175000017500000000002613243466361024130 0ustar exodistexodistrequire Test::Simple; Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/extras.plx0000644000175000017500000000031613243466361023764 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); ok(1); ok(1); ok(0); ok(1); ok(0); Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/death.plx0000644000175000017500000000037513243466361023550 0ustar exodistexodistrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); require Dev::Null; Test::Simple->import(tests => 5); tie *STDERR, 'Dev::Null'; ok(1); ok(1); ok(1); $! = 0; die "This is a test"; Test-Simple-1.302125/t/lib/Test/Simple/sample_tests/exit.plx0000644000175000017500000000004013243466361023421 0ustar exodistexodistrequire Test::Builder; exit 1; Test-Simple-1.302125/t/lib/Test/Simple/Catch.pm0000644000175000017500000000072013243466361020605 0ustar exodistexodist# For testing Test::Simple; package Test::Simple::Catch; use strict; use Symbol; use TieOut; my( $out_fh, $err_fh ) = ( gensym, gensym ); my $out = tie *$out_fh, 'TieOut'; my $err = tie *$err_fh, 'TieOut'; use Test::Builder; require Test::Builder::Formatter; my $t = Test::Builder->new; $t->{Stack}->top->format(Test::Builder::Formatter->new); $t->output($out_fh); $t->failure_output($err_fh); $t->todo_output($err_fh); sub caught { return( $out, $err ) } 1; Test-Simple-1.302125/t/lib/NoExporter.pm0000644000175000017500000000022613243466361017521 0ustar exodistexodistpackage NoExporter; use strict; our $VERSION = 1.02; sub import { shift; die "NoExporter exports nothing. You asked for: @_" if @_; } 1; Test-Simple-1.302125/t/lib/MyOverload.pm0000644000175000017500000000113713243466361017477 0ustar exodistexodistpackage Overloaded; ##no critic (Modules::RequireFilenameMatchesPackage) use strict; sub new { my $class = shift; bless { string => shift, num => shift }, $class; } package Overloaded::Compare; use strict; our @ISA = qw(Overloaded); # Sometimes objects have only comparison ops overloaded and nothing else. # For example, DateTime objects. use overload q{eq} => sub { $_[0]->{string} eq $_[1] }, q{==} => sub { $_[0]->{num} == $_[1] }; package Overloaded::Ify; use strict; our @ISA = qw(Overloaded); use overload q{""} => sub { $_[0]->{string} }, q{0+} => sub { $_[0]->{num} }; 1; Test-Simple-1.302125/t/lib/SmallTest.pm0000644000175000017500000000052013243466361017321 0ustar exodistexodistuse strict; use warnings; package SmallTest; require Exporter; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( ok is_eq is_num ); use Test::Builder; my $Test = Test::Builder->new; sub ok { $Test->ok(@_); } sub is_eq { $Test->is_eq(@_); } sub is_num { $Test->is_num(@_); } sub getTest { return $Test; } 1; Test-Simple-1.302125/t/lib/Dev/0000755000175000017500000000000013243466361015574 5ustar exodistexodistTest-Simple-1.302125/t/lib/Dev/Null.pm0000644000175000017500000000012713243466361017044 0ustar exodistexodistpackage Dev::Null; use strict; sub TIEHANDLE { bless {}, shift } sub PRINT { 1 } 1; Test-Simple-1.302125/t/lib/SkipAll.pm0000644000175000017500000000010713243466361016751 0ustar exodistexodistpackage SkipAll; use strict; use warnings; main::skip_all("foo"); 1; Test-Simple-1.302125/t/lib/MyTest.pm0000644000175000017500000000017713243466361016646 0ustar exodistexodistuse strict; use warnings; package MyTest; use Test::Builder; my $Test = Test::Builder->new; sub ok { $Test->ok(@_); } 1; Test-Simple-1.302125/t/lib/SigDie.pm0000644000175000017500000000011713243466361016557 0ustar exodistexodistpackage SigDie; use strict; our $DIE; $SIG{__DIE__} = sub { $DIE = $@ }; 1; Test-Simple-1.302125/t/lib/TieOut.pm0000644000175000017500000000056413243466361016632 0ustar exodistexodistpackage TieOut; use strict; sub TIEHANDLE { my $scalar = ''; bless( \$scalar, $_[0] ); } sub PRINT { my $self = shift; $$self .= join( '', @_ ); } sub PRINTF { my $self = shift; my $fmt = shift; $$self .= sprintf $fmt, @_; } sub FILENO { } sub read { my $self = shift; my $data = $$self; $$self = ''; return $data; } 1; Test-Simple-1.302125/t/lib/Dummy.pm0000644000175000017500000000006713243466361016512 0ustar exodistexodistpackage Dummy; use strict; our $VERSION = '0.01'; 1; Test-Simple-1.302125/t/00-report.t0000644000175000017500000000271213243466361016227 0ustar exodistexodistuse strict; use warnings; my $exit = 0; END{ $? = $exit } use File::Spec; my ($stderr, $stdout); BEGIN { $exit = 0; END{ $? = $exit } print STDOUT "ok 1\n"; print STDOUT "1..1\n"; open($stdout, '>&STDOUT') or die "Could not clone STDOUT: $!"; open($stderr, '>&STDERR') or die "Could not clone STDERR: $!"; close(STDOUT) or die "Could not close STDOUT"; unless(close(STDERR)) { print $stderr "Could not close STDERR\n"; $exit = 255; exit $exit; } open(STDOUT, '>', File::Spec->devnull); open(STDERR, '>', File::Spec->devnull); } use Test2::Util qw/CAN_FORK CAN_REALLY_FORK CAN_THREAD/; use Test2::API; sub diag { print $stderr "\n" unless @_; print $stderr "# $_\n" for @_; } diag; diag "DIAGNOSTICS INFO IN CASE OF FAILURE:"; diag; diag "Perl: $]"; diag; diag "CAPABILITIES:"; diag 'CAN_FORK ' . (CAN_FORK ? 'Yes' : 'No'); diag 'CAN_REALLY_FORK ' . (CAN_REALLY_FORK ? 'Yes' : 'No'); diag 'CAN_THREAD ' . (CAN_THREAD ? 'Yes' : 'No'); diag; diag "DEPENDENCIES:"; my @depends = sort qw{ Carp File::Spec File::Temp PerlIO Scalar::Util Storable Test2 overload threads utf8 }; my %deps; my $len = 0; for my $dep (@depends) { my $l = length($dep); $len = $l if $l > $len; $deps{$dep} = eval "require $dep" ? ($dep->VERSION || '0') : 'N/A'; } diag sprintf("%-${len}s %s", $_, $deps{$_}) for @depends; END{ $? = $exit } Test-Simple-1.302125/t/00compile.t0000644000175000017500000000213613243466361016267 0ustar exodistexodist#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::More; my $Has_Test_Pod; BEGIN { $Has_Test_Pod = eval 'use Test::Pod 0.95; 1'; } chdir ".."; my $manifest = "MANIFEST"; open(my $manifest_fh, "<", $manifest) or plan(skip_all => "Can't open $manifest: $!"); my @modules = map { m{^lib/(\S+)}; $1 } grep { m{^lib/Test/\S*\.pm} } grep { !m{/t/} } <$manifest_fh>; chomp @modules; close $manifest_fh; chdir 'lib'; plan tests => scalar @modules * 2; foreach my $file (@modules) { # Make sure we look at the local files and do not reload them if # they're already loaded. This avoids recompilation warnings. local @INC = @INC; unshift @INC, "."; my @warnings; ok eval { local $SIG{__WARN__} = sub { push @warnings => @_ }; require($file); 1 } or diag "require $file failed.", "\n", @warnings, "\n", $@; SKIP: { skip "Test::Pod not installed", 1 unless $Has_Test_Pod; pod_file_ok($file); } } Test-Simple-1.302125/t/HashBase.t0000644000175000017500000001274213243466361016161 0ustar exodistexodistuse strict; use warnings; use Test::More; sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } BEGIN { $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__; package main::HBase; use Test2::Util::HashBase qw/foo bar baz/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); } BEGIN { package main::HBaseSub; use base 'main::HBase'; use Test2::Util::HashBase qw/apple pear/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); main::is(APPLE, 'apple', "APPLE CONSTANT"); main::is(PEAR, 'pear', "PEAR CONSTANT"); } my $one = main::HBase->new(foo => 'a', bar => 'b', baz => 'c'); is($one->foo, 'a', "Accessor"); is($one->bar, 'b', "Accessor"); is($one->baz, 'c', "Accessor"); $one->set_foo('x'); is($one->foo, 'x', "Accessor set"); $one->set_foo(undef); is_deeply( $one, { foo => undef, bar => 'b', baz => 'c', }, 'hash' ); BEGIN { package main::Const::Test; use Test2::Util::HashBase qw/foo/; sub do_it { if (FOO()) { return 'const'; } return 'not const' } } my $pkg = 'main::Const::Test'; is($pkg->do_it, 'const', "worked as expected"); { local $SIG{__WARN__} = sub { }; *main::Const::Test::FOO = sub { 0 }; } ok(!$pkg->FOO, "overrode const sub"); { local $TODO = "known to fail on $]" if $] le "5.006002"; is($pkg->do_it, 'const', "worked as expected, const was constant"); } BEGIN { $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__; package main::HBase::Wrapped; use Test2::Util::HashBase qw/foo bar dup/; my $foo = __PACKAGE__->can('foo'); no warnings 'redefine'; *foo = sub { my $self = shift; $self->set_bar(1); $self->$foo(@_); }; } BEGIN { $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__; package main::HBase::Wrapped::Inherit; use base 'main::HBase::Wrapped'; use Test2::Util::HashBase qw/baz dup/; } my $o = main::HBase::Wrapped::Inherit->new(foo => 1); my $foo = $o->foo; is($o->bar, 1, 'parent attribute sub not overridden'); { package Foo; sub new; use Test2::Util::HashBase qw/foo bar baz/; sub new { 'foo' }; } is(Foo->new, 'foo', "Did not override existing 'new' method"); BEGIN { $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__; package main::HBase2; use Test2::Util::HashBase qw/foo -bar ^baz/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); } my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz'); is($ro->foo, 'foo', "got foo"); is($ro->bar, 'bar', "got bar"); is($ro->baz, 'baz', "got baz"); is($ro->set_foo('xxx'), 'xxx', "Can set foo"); is($ro->foo, 'xxx', "got foo"); like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar"); my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') }; like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning"); is_deeply( [Test2::Util::HashBase::attr_list('main::HBase::Wrapped::Inherit')], [qw/foo bar dup baz/], "Got a list of attributes in order starting from base class, duplicates removed", ); my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2); is($x->foo, 1, "set foo via pairs"); is($x->baz, 2, "set baz via pairs"); # Now with hashref my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2}); is($y->foo, 1, "set foo via hashref"); is($y->baz, 2, "set baz via hashref"); # Now with hashref my $z = main::HBase::Wrapped::Inherit->new([ 1, # foo 2, # bar 3, # dup 4, # baz ]); is($z->foo, 1, "set foo via arrayref"); is($z->baz, 4, "set baz via arrayref"); like( exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) }, qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/, "Too many args in array form" ); my $CAN_COUNT = 0; my $CAN_COUNT2 = 0; my $INIT_COUNT = 0; BEGIN { $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__; package main::HBase3; use Test2::Util::HashBase qw/foo/; sub can { my $self = shift; $CAN_COUNT++; $self->SUPER::can(@_); } $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__; package main::HBase4; use Test2::Util::HashBase qw/foo/; sub can { my $self = shift; $CAN_COUNT2++; $self->SUPER::can(@_); } sub init { $INIT_COUNT++ } } is($CAN_COUNT, 0, "->can has not been called yet"); my $it = main::HBase3->new; is($CAN_COUNT, 1, "->can has been called once to check for init"); $it = main::HBase3->new; is($CAN_COUNT, 1, "->can was not called again, we cached it"); is($CAN_COUNT2, 0, "->can has not been called yet"); is($INIT_COUNT, 0, "->init has not been called yet"); $it = main::HBase4->new; is($CAN_COUNT2, 1, "->can has been called once to check for init"); is($INIT_COUNT, 1, "->init has been called once"); $it = main::HBase4->new; is($CAN_COUNT2, 1, "->can was not called again, we cached it"); is($INIT_COUNT, 2, "->init has been called again"); done_testing; 1; Test-Simple-1.302125/appveyor.yml0000644000175000017500000000126513243466361016441 0ustar exodistexodistskip_tags: true cache: - C:\strawberry install: - if not exist "C:\strawberry" cinst strawberryperl -y - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% - cd C:\projects\%APPVEYOR_PROJECT_NAME% - cpanm -n Dist::Zilla Pod::Markdown - dzil authordeps --missing | cpanm -n - dzil listdeps --author --missing | cpanm build_script: - perl -e 2 test_script: - dzil test notifications: - provider: Slack auth_token: secure: 1XmVVszAQyTtMdNkyWup8p7AC9iqXkMl6QMchq3Xu7L7rCzYgjjlS/mas+bfp3ouyjPKnoh01twl4eB0Xs/1Ig== channel: '#general' on_build_success: false on_build_failure: true on_build_status_changed: true Test-Simple-1.302125/Makefile.PL0000644000175000017500000000346013243466361016022 0ustar exodistexodist# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.010. use strict; use warnings; use 5.006002; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Basic utilities for writing tests.", "AUTHOR" => "Chad Granum ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "Test-Simple", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.006002", "NAME" => "Test::Simple", "PREREQ_PM" => { "File::Spec" => 0, "File::Temp" => 0, "Scalar::Util" => "1.13", "Storable" => 0, "utf8" => 0 }, "VERSION" => "1.302125", "test" => { "TESTS" => "t/*.t t/Legacy/*.t t/Legacy/Bugs/*.t t/Legacy/Builder/*.t t/Legacy/Regression/*.t t/Legacy/Simple/*.t t/Legacy/Test2/*.t t/Legacy/Tester/*.t t/Legacy/subtest/*.t t/Legacy_And_Test2/*.t t/Test2/acceptance/*.t t/Test2/behavior/*.t t/Test2/legacy/*.t t/Test2/modules/*.t t/Test2/modules/API/*.t t/Test2/modules/Event/*.t t/Test2/modules/Event/TAP/*.t t/Test2/modules/EventFacet/*.t t/Test2/modules/Formatter/*.t t/Test2/modules/Hub/*.t t/Test2/modules/Hub/Interceptor/*.t t/Test2/modules/IPC/*.t t/Test2/modules/IPC/Driver/*.t t/Test2/modules/Tools/*.t t/Test2/modules/Util/*.t t/Test2/regression/*.t t/regression/*.t" } ); my %FallbackPrereqs = ( "File::Spec" => 0, "File::Temp" => 0, "Scalar::Util" => "1.13", "Storable" => 0, "utf8" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{INSTALLDIRS} = 'perl' if "$]" >= 5.006002 && "$]" <= 5.011000; WriteMakefile(%WriteMakefileArgs); Test-Simple-1.302125/README.md0000644000175000017500000001520713243466361015331 0ustar exodistexodist# NAME Test2 - Framework for writing test tools that all work together. # DESCRIPTION Test2 is a new testing framework produced by forking [Test::Builder](https://metacpan.org/pod/Test::Builder), completely refactoring it, adding many new features and capabilities. ## WHAT IS NEW? - Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with `Test2::API::intercept()`. - Better diagnostics capabilities. Test2 uses an [Test2::API::Context](https://metacpan.org/pod/Test2::API::Context) object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. - Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. - More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. - Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. - Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. - Support for threading/forking. Test2 support for forking and threading can be turned on using [Test2::IPC](https://metacpan.org/pod/Test2::IPC). Once turned on threading and forking operate sanely and work as one would expect. # GETTING STARTED If you are interested in writing tests using new tools then you should look at [Test2::Suite](https://metacpan.org/pod/Test2::Suite). [Test2::Suite](https://metacpan.org/pod/Test2::Suite) is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at [Test2::API](https://metacpan.org/pod/Test2::API) first. # NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in [Test2::Suite](https://metacpan.org/pod/Test2::Suite). ## Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like `ok()` and `is()`. Most things written for Test2 should go here. Modules in this namespace **MUST NOT** export subs from other tools. See the ["Test2::Bundle::"](#test2-bundle) namespace if you want to do that. ## Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. ## Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. ## Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. ## Test2::Formatter:: Formatters live under this namespace. [Test2::Formatter::TAP](https://metacpan.org/pod/Test2::Formatter::TAP) is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. ## Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. ## Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. ## Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. ### Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. ## Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. ## Test2::API:: This is for Test2 API and related packages. ## Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into `Test2::XXX`. # SEE ALSO [Test2::API](https://metacpan.org/pod/Test2::API) - Primary API functions. [Test2::API::Context](https://metacpan.org/pod/Test2::API::Context) - Detailed documentation of the context object. [Test2::IPC](https://metacpan.org/pod/Test2::IPC) - The IPC system used for threading/fork support. [Test2::Formatter](https://metacpan.org/pod/Test2::Formatter) - Formatters such as TAP live here. [Test2::Event](https://metacpan.org/pod/Test2::Event) - Events live in this namespace. [Test2::Hub](https://metacpan.org/pod/Test2::Hub) - All events eventually funnel through a hub. Custom hubs are how `intercept()` and `run_subtest()` are implemented. # CONTACTING US Many Test2 developers and users lurk on [irc://irc.perl.org/#perl-qa](irc://irc.perl.org/#perl-qa) and [irc://irc.perl.org/#toolchain](irc://irc.perl.org/#toolchain). We also have a slack team that can be joined by anyone with an `@cpan.org` email address [https://perl-test2.slack.com/](https://perl-test2.slack.com/) If you do not have an `@cpan.org` email you can ask for a slack invite by emailing Chad Granum . # SOURCE The source code repository for Test2 can be found at `http://github.com/Test-More/test-more/`. # MAINTAINERS - Chad Granum # AUTHORS - Chad Granum # COPYRIGHT Copyright 2018 Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See `http://dev.perl.org/licenses/` Test-Simple-1.302125/META.json0000644000175000017500000000420413243466361015466 0ustar exodistexodist{ "abstract" : "Basic utilities for writing tests.", "author" : [ "Chad Granum " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test-Simple", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "IPC::Open3" : "0", "Test::Pod" : "1.41", "Test::Spelling" : "0.12" } }, "runtime" : { "requires" : { "File::Spec" : "0", "File::Temp" : "0", "Scalar::Util" : "1.13", "Storable" : "0", "perl" : "5.006002", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/Test-More/test-more/issues" }, "repository" : { "type" : "git", "url" : "http://github.com/Test-More/test-more/" } }, "version" : "1.302125", "x_breaks" : { "Log::Dispatch::Config::TestLog" : "<= 0.02", "Net::BitTorrent" : "<= 0.052", "Test2::Harness" : "<= 0.000013", "Test2::Tools::EventDumper" : "<= 0.000007", "Test::Able" : "<= 0.11", "Test::Aggregate" : "<= 0.373", "Test::Alien" : "<= 0.04", "Test::Builder::Clutch" : "<= 0.07", "Test::Clustericious::Cluster" : "<= 0.30", "Test::Dist::VersionSync" : "<= v1.1.4", "Test::Exception" : "<= 0.42", "Test::Flatten" : "<= 0.11", "Test::Group" : "<= 0.20", "Test::Modern" : "<= 0.012", "Test::Moose" : "<= 2.1209", "Test::More::Prefix" : "<= 0.005", "Test::ParallelSubtest" : "<= 0.05", "Test::Pretty" : "<= 0.32", "Test::SharedFork" : "<= 0.34", "Test::UseAllModules" : ">= 0.12, <= 0.14", "Test::Wrapper" : "<= v0.3.0" }, "x_serialization_backend" : "Cpanel::JSON::XS version 4.00" } Test-Simple-1.302125/lib/0000755000175000017500000000000013243466361014613 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/0000755000175000017500000000000013243466361015614 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/EventFacet/0000755000175000017500000000000013243466361017640 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/EventFacet/Amnesty.pm0000644000175000017500000000315313243466361021620 0ustar exodistexodistpackage Test2::EventFacet::Amnesty; use strict; use warnings; our $VERSION = '1.302125'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -inherited }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Amnesty - Facet for assertion amnesty. =head1 DESCRIPTION This package represents what is expected in units of amnesty. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string = $amnesty->{details} =item $string = $amnesty->details() Human readable explanation of why amnesty was granted. Example: I =item $short_string = $amnesty->{tag} =item $short_string = $amnesty->tag() Short string (usually 10 characters or less, not enforced, but may be truncated by renderers) categorizing the amnesty. =item $bool = $amnesty->{inherited} =item $bool = $amnesty->inherited() This will be true if the amnesty was granted to a parent event and inherited by this event, which is a child, such as an assertion within a subtest that is marked todo. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Control.pm0000644000175000017500000000345413243466361021624 0ustar exodistexodistpackage Test2::EventFacet::Control; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Control - Facet for hub actions and behaviors. =head1 DESCRIPTION This facet is used when the event needs to give instructions to the Test2 internals. =head1 FIELDS =over 4 =item $string = $control->{details} =item $string = $control->details() Human readable explanation for the special behavior. =item $bool = $control->{global} =item $bool = $control->global() True if the event is global in nature and should be seen by all hubs. =item $exit = $control->{terminate} =item $exit = $control->terminate() Defined if the test should immediately exit, the value is the exit code and may be C<0>. =item $bool = $control->{halt} =item $bool = $control->halt() True if all testing should be halted immediately. =item $bool = $control->{has_callback} =item $bool = $control->has_callback() True if the C method on the event should be called. =item $encoding = $control->{encoding} =item $encoding = $control->encoding() This can be used to change the encoding from this event onward. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Assert.pm0000644000175000017500000000326013243466361021440 0ustar exodistexodistpackage Test2::EventFacet::Assert; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -pass -no_debug -number }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Assert - Facet representing an assertion. =head1 DESCRIPTION The assertion facet is provided by any event representing an assertion that was made. =head1 FIELDS =over 4 =item $string = $assert->{details} =item $string = $assert->details() Human readable description of the assertion. =item $bool = $assert->{pass} =item $bool = $assert->pass() True if the assertion passed. =item $bool = $assert->{no_debug} =item $bool = $assert->no_debug() Set this to true if you have provided custom diagnostics and do not want the defaults to be displayed. =item $int = $assert->{number} =item $int = $assert->number() (Optional) assertion number. This may be omitted or ignored. This is usually only useful when parsing/processing TAP. B: This is not set by the Test2 system, assertion number is not known until AFTER the assertion has been processed. This attribute is part of the spec only for harnesses. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Render.pm0000644000175000017500000000377713243466361021433 0ustar exodistexodistpackage Test2::EventFacet::Render; use strict; use warnings; our $VERSION = '1.302125'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -facet -mode }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Render - Facet that dictates how to render an event. =head1 DESCRIPTION This facet is used to dictate how the event should be rendered by the standard test2 rendering tools. If this facet is present then ONLY what is specified by it will be rendered. It is assumed that anything important or note-worthy will be present here, no other facets will be considered for rendering/display. This facet is a list type, you can add as many items as needed. =head1 FIELDS =over 4 =item $string = $render->[#]->{details} =item $string = $render->[#]->details() Human readable text for display. =item $string = $render->[#]->{tag} =item $string = $render->[#]->tag() Tag that should prefix/identify the main text. =item $string = $render->[#]->{facet} =item $string = $render->[#]->facet() Optional, if the display text was generated from another facet this should state what facet it was. =item $mode = $render->[#]->mode{} =item $mode = $render->[#]->mode() =over 4 =item calculated Calculated means the facet was generated from another facet. Calculated facets may be cleared and regenerated whenever the event state changes. =item replace Replace means the facet is intended to replace the normal rendering of the event. =back =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Parent.pm0000644000175000017500000000332013243466361021425 0ustar exodistexodistpackage Test2::EventFacet::Parent; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/confess/; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -hid -children -buffered }; sub init { confess "Attribute 'hid' must be set" unless defined $_[0]->{+HID}; $_[0]->{+CHILDREN} ||= []; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Parent - Base class for all event facets. =head1 DESCRIPTION This facet is used when an event contains other events, such as a subtest. =head1 FIELDS =over 4 =item $string = $parent->{details} =item $string = $parent->details() Human readable description of the event. =item $hid = $parent->{hid} =item $hid = $parent->hid() Hub ID of the hub that is represented in the parent-child relationship. =item $arrayref = $parent->{children} =item $arrayref = $parent->children() Arrayref containing the facet-data hashes of events nested under this one. I =item $bool = $parent->{buffered} =item $bool = $parent->buffered() True if the subtest is buffered (meaning the formatter has probably not seen them yet). =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Error.pm0000644000175000017500000000341313243466361021270 0ustar exodistexodistpackage Test2::EventFacet::Error; use strict; use warnings; our $VERSION = '1.302125'; sub facet_key { 'errors' } sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -fail }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Error - Facet for errors that need to be shown. =head1 DESCRIPTION This facet is used when an event needs to convey errors. =head1 NOTES This facet has the hash key C<'errors'>, and is a list of facets instead of a single item. =head1 FIELDS =over 4 =item $string = $error->{details} =item $string = $error->details() Explanation of the error, or the error itself (such as an exception). In perl exceptions may be blessed objects, so this field may contain a blessed object. =item $short_string = $error->{tag} =item $short_string = $error->tag() Short tag to categorize the error. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $error->{fail} =item $bool = $error->fail() Not all errors are fatal, some are displayed having already been handled. Set this to true if you want the error to cause the test to fail. Without this the error is simply a diagnostics message that has no effect on the overall pass/fail result. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/About.pm0000644000175000017500000000234013243466361021247 0ustar exodistexodistpackage Test2::EventFacet::About; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -package -no_display }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::About - Facet with event details. =head1 DESCRIPTION This facet has information about the event, such as event package. =head1 FIELDS =over 4 =item $string = $about->{details} =item $string = $about->details() Summary about the event. =item $package = $about->{package} =item $package = $about->package() Event package name. =item $bool = $about->{no_display} =item $bool = $about->no_display() True if the event should be skipped by formatters. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Trace.pm0000644000175000017500000001216413243466361021240 0ustar exodistexodistpackage Test2::EventFacet::Trace; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util qw/get_tid pkg_to_file/; use Carp qw/confess/; use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered}; { no warnings 'once'; *DETAIL = \&DETAILS; *detail = \&details; *set_detail = \&set_details; } sub init { confess "The 'frame' attribute is required" unless $_[0]->{+FRAME}; $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; } sub snapshot { my ($orig, @override) = @_; bless {%$orig, @override}, __PACKAGE__; } sub signature { my $self = shift; # Signature is only valid if all of these fields are defined, there is no # signature if any is missing. '0' is ok, but '' is not. return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( $self->{+CID}, $self->{+PID}, $self->{+TID}, $self->{+FRAME}->[1], $self->{+FRAME}->[2], ); } sub debug { my $self = shift; return $self->{+DETAILS} if $self->{+DETAILS}; my ($pkg, $file, $line) = $self->call; return "at $file line $line"; } sub alert { my $self = shift; my ($msg) = @_; warn $msg . ' ' . $self->debug . ".\n"; } sub throw { my $self = shift; my ($msg) = @_; die $msg . ' ' . $self->debug . ".\n"; } sub call { @{$_[0]->{+FRAME}} } sub package { $_[0]->{+FRAME}->[0] } sub file { $_[0]->{+FRAME}->[1] } sub line { $_[0]->{+FRAME}->[2] } sub subname { $_[0]->{+FRAME}->[3] } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Trace - Debug information for events =head1 DESCRIPTION The L object, as well as all L types need to have access to information about where they were created. This object represents that information. =head1 SYNOPSIS use Test2::EventFacet::Trace; my $trace = Test2::EventFacet::Trace->new( frame => [$package, $file, $line, $subname], ); =head1 FACET FIELDS =over 4 =item $string = $trace->{details} =item $string = $trace->details() Used as a custom trace message that will be used INSTEAD of C<< at line >> when calling C<< $trace->debug >>. =item $frame = $trace->{frame} =item $frame = $trace->frame() Get the call frame arrayref. =item $int = $trace->{pid} =item $int = $trace->pid() The process ID in which the event was generated. =item $int = $trace->{tid} =item $int = $trace->tid() The thread ID in which the event was generated. =item $id = $trace->{cid} =item $id = $trace->cid() The ID of the context that was used to create the event. =item $hid = $trace->{hid} =item $hid = $trace->hid() The ID of the hub that was current when the event was created. =item $int = $trace->{nested} =item $int = $trace->nested() How deeply nested the event is. =item $bool = $trace->{buffered} =item $bool = $trace->buffered() True if the event was buffered and not sent to the formatter independent of a parent (This should never be set when nested is C<0> or C). =back =head1 METHODS B All facet frames are also methods. =over 4 =item $trace->set_detail($msg) =item $msg = $trace->detail Used to get/set a custom trace message that will be used INSTEAD of C<< at line >> when calling C<< $trace->debug >>. C is an alias to the C
facet field for backwards compatibility. =item $str = $trace->debug Typically returns the string C<< at line >>. If C is set then its value will be returned instead. =item $trace->alert($MESSAGE) This issues a warning at the frame (filename and line number where errors should be reported). =item $trace->throw($MESSAGE) This throws an exception at the frame (filename and line number where errors should be reported). =item ($package, $file, $line, $subname) = $trace->call() Get the caller details for the debug-info. This is where errors should be reported. =item $pkg = $trace->package Get the debug-info package. =item $file = $trace->file Get the debug-info filename. =item $line = $trace->line Get the debug-info line number. =item $subname = $trace->subname Get the debug-info subroutine name. =item $sig = trace->signature Get a signature string that identifies this trace. This is used to check if multiple events are related. The Trace includes pid, tid, file, line number, and the cid which is C<'C\d+'> for traces created by a context, or C<'T\d+'> for traces created by C. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Plan.pm0000644000175000017500000000353613243466361021077 0ustar exodistexodistpackage Test2::EventFacet::Plan; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -count -skip -none }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Plan - Facet for setting the plan =head1 DESCRIPTION Events use this facet when they need to set the plan. =head1 FIELDS =over 4 =item $string = $plan->{details} =item $string = $plan->details() Human readable explanation for the plan being set. This is normally not rendered by most formatters except when the C field is also set. =item $positive_int = $plan->{count} =item $positive_int = $plan->count() Set the number of expected assertions. This should usually be set to C<0> when C or C are also set. =item $bool = $plan->{skip} =item $bool = $plan->skip() When true the entire test should be skipped. This is usually paired with an explanation in the C
field, and a C facet that has C set to C<0>. =item $bool = $plan->{none} =item $bool = $plan->none() This is mainly used by legacy L tests which set the plan to C, a construct that predates the much better C. If you are using this in non-legacy code you may need to reconsider the course of your life, maybe a hermitage would suite you? =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Info.pm0000644000175000017500000000415713243466361021100 0ustar exodistexodistpackage Test2::EventFacet::Info; use strict; use warnings; our $VERSION = '1.302125'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-tag -debug -important}; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Info - Facet for information a developer might care about. =head1 DESCRIPTION This facet represents messages intended for humans that will help them either understand a result, or diagnose a failure. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string_or_structure = $info->{details} =item $string_or_structure = $info->details() Human readable string or data structure, this is the information to display. Formatters are free to render the structures however they please. This may contain a blessed object. =item $short_string = $info->{tag} =item $short_string = $info->tag() Short tag to categorize the info. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $info->{debug} =item $bool = $info->debug() Set this to true if the message is critical, or explains a failure. This is info that should be displayed by formatters even in less-verbose modes. When false the information is not considered critical and may not be rendered in less-verbose modes. =item $bool = $info->{important} =item $bool = $info->important This should be set for non debug messages that are still important enough to show when a formatter is in quiet mode. A formatter should send these to STDOUT not STDERR, but should show them even in non-verbose mode. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet/Meta.pm0000644000175000017500000000350613243466361021070 0ustar exodistexodistpackage Test2::EventFacet::Meta; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use vars qw/$AUTOLOAD/; # replace set_details { no warnings 'redefine'; sub set_details { $_[0]->{'set_details'} } } sub can { my $self = shift; my ($name) = @_; my $existing = $self->SUPER::can($name); return $existing if $existing; # Only vivify when called on an instance, do not vivify for a class. There # are a lot of magic class methods used in things like serialization (or # the forks.pm module) which cause problems when vivified. return undef unless ref($self); my $sub = sub { $_[0]->{$name} }; { no strict 'refs'; *$name = $sub; } return $sub; } sub AUTOLOAD { my $name = $AUTOLOAD; $name =~ s/^.*:://g; my $sub = $_[0]->can($name); goto &$sub; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Meta - Facet for meta-data =head1 DESCRIPTION This facet can contain any random meta-data that has been attached to the event. =head1 METHODS AND FIELDS Any/all fields and accessors are autovivified into existence. There is no way to know what metadata may be added, so any is allowed. =over 4 =item $anything = $meta->{anything} =item $anything = $meta->anything() =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Formatter/0000755000175000017500000000000013243466361017557 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Formatter/TAP.pm0000644000175000017500000003011613243466361020542 0ustar exodistexodistpackage Test2::Formatter::TAP; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Util qw/clone_io/; use Test2::Util::HashBase qw{ no_numbers handles _encoding _last_fh -made_assertion }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } sub _autoflush { my($fh) = pop; my $old_fh = select $fh; $| = 1; select $old_fh; } _autoflush(\*STDOUT); _autoflush(\*STDERR); sub hide_buffered { 1 } sub init { my $self = shift; $self->{+HANDLES} ||= $self->_open_handles; if(my $enc = delete $self->{encoding}) { $self->encoding($enc); } } sub _open_handles { my $self = shift; require Test2::API; my $out = clone_io(Test2::API::test2_stdout()); my $err = clone_io(Test2::API::test2_stderr()); _autoflush($out); _autoflush($err); return [$out, $err]; } sub encoding { my $self = shift; if ($] ge "5.007003" and @_) { my ($enc) = @_; my $handles = $self->{+HANDLES}; # https://rt.perl.org/Public/Bug/Display.html?id=31923 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in # order to avoid the thread segfault. if ($enc =~ m/^utf-?8$/i) { binmode($_, ":utf8") for @$handles; } else { binmode($_, ":encoding($enc)") for @$handles; } $self->{+_ENCODING} = $enc; } return $self->{+_ENCODING}; } if ($^C) { no warnings 'redefine'; *write = sub {}; } sub write { my ($self, $e, $num, $f) = @_; # The most common case, a pass event with no amnesty and a normal name. return if $self->print_optimal_pass($e, $num); $f ||= $e->facet_data; $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; my @tap = $self->event_tap($f, $num) or return; $self->{+MADE_ASSERTION} = 1 if $f->{assert}; my $nesting = $f->{trace}->{nested} || 0; my $handles = $self->{+HANDLES}; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. local($\, $,) = (undef, '') if $\ || $,; for my $set (@tap) { no warnings 'uninitialized'; my ($hid, $msg) = @$set; next unless $msg; my $io = $handles->[$hid] or next; print $io "\n" if $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} && $hid == OUT_ERR && $self->{+_LAST_FH} != $io && $msg =~ m/^#\s*Failed test /; $msg =~ s/^/$indent/mg if $nesting; print $io $msg; $self->{+_LAST_FH} = $io; } } sub print_optimal_pass { my ($self, $e, $num) = @_; my $type = ref($e); # Only optimal if this is a Pass or a passing Ok return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); # Amnesty requires further processing (todo is a form of amnesty) return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); # A name with a newline or hash symbol needs extra processing return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); my $ok = 'ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; if (my $nesting = $e->{trace}->{nested}) { my $indent = ' ' x $nesting; $ok = "$indent$ok"; } my $io = $self->{+HANDLES}->[OUT_STD]; local($\, $,) = (undef, '') if $\ || $,; print $io $ok; $self->{+_LAST_FH} = $io; return 1; } sub event_tap { my ($self, $f, $num) = @_; my @tap; # If this IS the first event the plan should come first # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; # The assertion is most important, if present. if ($f->{assert}) { push @tap => $self->assert_tap($f, $num); push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; } # Almost as important as an assertion push @tap => $self->error_tap($f) if $f->{errors}; # Now lets see the diagnostics messages push @tap => $self->info_tap($f) if $f->{info}; # If this IS NOT the first event the plan should come last # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; # Bail out push @tap => $self->halt_tap($f) if $f->{control}->{halt}; return @tap if @tap; return @tap if $f->{control}->{halt}; return @tap if grep { $f->{$_} } qw/assert plan info errors/; # Use the summary as a fallback if nothing else is usable. return $self->summary_tap($f, $num); } sub error_tap { my $self = shift; my ($f) = @_; my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; return map { my $details = $_->{details}; my $msg; if (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{errors}}; } sub plan_tap { my $self = shift; my ($f) = @_; my $plan = $f->{plan} or return; return if $plan->{none}; if ($plan->{skip}) { my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; chomp($reason); return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; } return [OUT_STD, "1.." . $plan->{count} . "\n"]; } sub no_subtest_space { 0 } sub assert_tap { my $self = shift; my ($f, $num) = @_; my $assert = $f->{assert} or return; my $pass = $assert->{pass}; my $name = $assert->{details}; my $ok = $pass ? 'ok' : 'not ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; # The regex form is ~250ms, the index form is ~50ms my @extra; defined($name) && ( (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) ); my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; my $extra_indent = ''; my ($directives, $reason, $is_skip); if ($f->{amnesty}) { my %directives; for my $am (@{$f->{amnesty}}) { next if $am->{inherited}; my $tag = $am->{tag} or next; $is_skip = 1 if $tag eq 'skip'; $directives{$tag} ||= $am->{details}; } my %seen; my @order = grep { !$seen{$_}++ } sort keys %directives; $directives = ' # ' . join ' & ' => @order; for my $tag ('skip', @order) { next unless defined($directives{$tag}) && length($directives{$tag}); $reason = $directives{$tag}; last; } } $ok .= " - $name" if defined $name && !($is_skip && !$name); my @subtap; if ($f->{parent} && $f->{parent}->{buffered}) { $ok .= ' {'; # In a verbose harness we indent the extra since they will appear # inside the subtest braces. This helps readability. In a non-verbose # harness we do not do this because it is less readable. if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { $extra_indent = " "; $extra_space = ' '; } # Render the sub-events, we use our own counter for these. my $count = 0; @subtap = map { my $f2 = $_; # Bump the count for any event that should bump it. $count++ if $f2->{assert}; # This indents all output lines generated for the sub-events. # index 0 is the filehandle, index 1 is the message we want to indent. map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count); } @{$f->{parent}->{children}}; push @subtap => [OUT_STD, "}\n"]; } if ($directives) { $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; $ok .= $directives; $ok .= " $reason" if defined($reason); } $extra_space = ' ' if $self->no_subtest_space; my @out = ([OUT_STD, "$ok\n"]); push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; push @out => @subtap; return @out; } sub debug_tap { my ($self, $f, $num) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $f->{assert}->{details}; my $trace = $f->{trace}; my $debug = "[No trace info available]"; if ($trace->{details}) { $debug = $trace->{details}; } elsif ($trace->{frame}) { my ($pkg, $file, $line) = @{$trace->{frame}}; $debug = "at $file line $line." if $file && $line; } my $amnesty = $f->{amnesty} && @{$f->{amnesty}} ? ' (with amnesty)' : ''; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[# Failed test${amnesty} '$name'\n# $debug\n] : qq[# Failed test${amnesty} $debug\n]; my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; return [$IO, $msg]; } sub halt_tap { my ($self, $f) = @_; return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; my $details = $f->{control}->{details}; return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); return [OUT_STD, "Bail out! $details\n"]; } sub info_tap { my ($self, $f) = @_; return map { my $details = $_->{details}; my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; my $msg; if (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{info}}; } sub summary_tap { my ($self, $f, $num) = @_; return if $f->{about}->{no_display}; my $summary = $f->{about}->{details} or return; chomp($summary); $summary =~ s/^/# /smg; return [OUT_STD, "$summary\n"]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter::TAP - Standard TAP formatter =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test2::Formatter::TAP; my $tap = Test2::Formatter::TAP->new(); # Switch to utf8 $tap->encoding('utf8'); $tap->write($event, $number); # Output an event =head1 METHODS =over 4 =item $bool = $tap->no_numbers =item $tap->set_no_numbers($bool) Use to turn numbers on and off. =item $arrayref = $tap->handles =item $tap->set_handles(\@handles); Can be used to get/set the filehandles. Indexes are identified by the C and C constants. =item $encoding = $tap->encoding =item $tap->encoding($encoding) Get or set the encoding. By default no encoding is set, the original settings of STDOUT and STDERR are used. This directly modifies the stored filehandles, it does not create new ones. =item $tap->write($e, $num) Write an event to the console. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Hub/0000755000175000017500000000000013243466361016332 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Hub/Interceptor/0000755000175000017500000000000013243466361020630 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Hub/Interceptor/Terminator.pm0000644000175000017500000000134013243466361023310 0ustar exodistexodistpackage Test2::Hub::Interceptor::Terminator; use strict; use warnings; our $VERSION = '1.302125'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor::Terminator - Exception class used by Test2::Hub::Interceptor =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Hub/Interceptor.pm0000644000175000017500000000262713243466361021175 0ustar exodistexodistpackage Test2::Hub::Interceptor; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Hub::Interceptor::Terminator(); BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; sub init { my $self = shift; $self->SUPER::init; $self->{+NESTED} = 0; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} = 0; if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } } sub terminate { my $self = shift; my ($code) = @_; eval { no warnings 'exiting'; last T2_SUBTEST_WRAPPER; }; my $err = $@; # Fallback die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor - Hub used by interceptor to grab results. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Hub/Subtest.pm0000644000175000017500000000512013243466361020317 0ustar exodistexodistpackage Test2::Hub::Subtest; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; use Test2::Util qw/get_tid/; sub is_subtest { 1 } sub inherit { my $self = shift; my ($from) = @_; $self->SUPER::inherit($from); $self->{+NESTED} = $from->nested + 1; } { # Legacy no warnings 'once'; *ID = \&Test2::Hub::HID; *id = \&Test2::Hub::hid; *set_id = \&Test2::Hub::set_hid; } sub send { my $self = shift; my ($e) = @_; my $out = $self->SUPER::send($e); return $out if $self->{+MANUAL_SKIP_ALL}; my $f = $e->facet_data; my $plan = $f->{plan} or return $out; return $out unless $plan->{skip}; my $trace = $f->{trace} or die "Missing Trace!"; return $out unless $trace->{pid} != $self->pid || $trace->{tid} != $self->tid; no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } sub terminate { my $self = shift; my ($code, $e, $f) = @_; $self->set_exit_code($code); return if $self->{+MANUAL_SKIP_ALL}; $f ||= $e->facet_data; if(my $plan = $f->{plan}) { my $trace = $f->{trace} or die "Missing Trace!"; return if $plan->{skip} && ($trace->{pid} != $$ || $trace->{tid} != get_tid); } no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Subtest - Hub used by subtests =head1 DESCRIPTION Subtests make use of this hub to route events. =head1 TOGGLES =over 4 =item $bool = $hub->manual_skip_all =item $hub->set_manual_skip_all($bool) The default is false. Normally a skip-all plan event will cause a subtest to stop executing. This is accomplished via C to a label inside the subtest code. Most of the time this is perfectly fine. There are times however where this flow control causes bad things to happen. This toggle lets you turn off the abort logic for the hub. When this is toggled to true B are responsible for ensuring no additional events are generated. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Transition.pod0000644000175000017500000003224613243466361020461 0ustar exodistexodist=pod =head1 NAME Test2::Transition - Transition notes when upgrading to Test2 =head1 DESCRIPTION This is where gotchas and breakages related to the Test2 upgrade are documented. The upgrade causes Test::Builder to defer to Test2 under the hood. This transition is mostly transparent, but there are a few cases that can trip you up. =head1 THINGS THAT BREAK This is the list of scenarios that break with the new internals. =head2 Test::Builder1.5/2 conditionals =head3 The Problem a few years back there were two attempts to upgrade/replace Test::Builder. Confusingly these were called Test::Builder2 and Test::Builder1.5, in that order. Many people put conditionals in their code to check the Test::Builder version number and adapt their code accordingly. The Test::Builder2/1.5 projects both died out. Now the conditional code people added has become a mine field. A vast majority of modules broken by Test2 fall into this category. =head3 The Fix The fix is to remove all Test::Builder1.5/2 related code. Either use the legacy Test::Builder API, or use Test2 directly. =head2 Replacing the Test::Builder singleton =head3 The Problem Some test modules would replace the Test::Builder singleton instance with their own instance or subclass. This was usually done to intercept or modify results as they happened. The Test::Builder singleton is now a simple compatibility wrapper around Test2. The Test::Builder singleton is no longer the central place for results. Many results bypass the Test::Builder singleton completely, which breaks and behavior intended when replacing the singleton. =head3 The Fix If you simply want to intercept all results instead of letting them go to TAP, you should look at the L docs and read about pushing a new hub onto the hub stack. Replacing the hub temporarily is now the correct way to intercept results. If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >> method exported by Test::More to watch events as they are fired. If you wish to modify results before they go to TAP look at the C<< Test2::Hub->filter() >> method. =head2 Directly Accessing Hash Elements =head3 The Problem Some modules look directly at hash keys on the Test::Builder singleton. The problem here is that the Test::Builder singleton no longer holds anything important. =head3 The Fix The fix is to use the API specified in L to look at or modify state as needed. =head2 Subtest indentation =head3 The Problem An early change, in fact the change that made Test2 an idea, was a change to the indentation of the subtest note. IT was decided it would be more readable to outdent the subtest note instead of having it inline with the subtest: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo The old style indented the note: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo This breaks tests that do string comparison of TAP output. =head3 The Fix my $indent = $INC{'Test2/API.pm'} ? '' : ' '; is( $subtest_output, "${indent}# subtest foo", "Got subtest note" ); Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be expected. If it is not set than the old Test::Builder is in use, indentation should be expected. =head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED This is a list of cpan modules that have been known to have been broken by the upgrade at one point. =head2 WORKS BUT TESTS WILL FAIL These modules still function correctly, but their test suites will not pass. If you already have these modules installed then you can continue to use them. If you are trying to install them after upgrading Test::Builder you will need to force installation, or bypass the broken tests. =over 4 =item Test::DBIx::Class::Schema This module has a test that appears to work around a Test::Builder bug. The bug appears to have been fixed by Test2, which means the workaround causes a failure. This can be easily updated, but nobody has done so yet. Known broken in versions: 1.0.9 and older =item Test::Kit This actually works fine, but will not install because L is in the dependency chain. See the L info below for additional information. =item Device::Chip Tests break due to subtest indentation. Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has been submitted to fix the issue. =back =head2 UPGRADE SUGGESTED These are modules that did not break, but had broken test suites that have since been fixed. =over 4 =item Test::Exception Old versions work fine, but have a minor test name behavior that breaks with Test2. Old versions will no longer install because of this. The latest version on CPAN will install just fine. Upgrading is not required, but is recommended. Fixed in version: 0.43 =item Data::Peek Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch was applied to correct things that changed. The module itself works fine, there is no need to upgrade. Fixed in version: 0.45 =item circular::require Some tests were fragile and required base.pm to be loaded at a late stage. Test2 was loading base.pm too early. The tests were updated to fix this. The module itself never broke, you do not need to upgrade. Fixed in version: 0.12 =item Test::Module::Used A test worked around a now-fixed planning bug. There is no need to upgrade if you have an old version installed. New versions install fine if you want them. Fixed in version: 0.2.5 =item Test::Moose::More Some tests were fragile, but have been fixed. The actual breakage was from the subtest comment indentation change. No need to upgrade, old versions work fine. Only new versions will install. Fixed in version: 0.025 =item Test::FITesque This was broken by a bugfix to how planning is done. The test was updated after the bugfix. Fixed in version: 0.04 =item autouse A test broke because it depended on Scalar::Util not being loaded. Test2 loads Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's load status. There is no need to upgrade if you already have it installed. Fixed in version: 1.11 =back =head2 NEED TO UPGRADE =over 4 =item Test::SharedFork Old versions need to directly access Test::Builder singleton hash elements. The latest version on CPAN will still do this on old Test::Builder, but will defer to L on Test2. Fixed in version: 0.35 =item Test::Builder::Clutch This works by doing overriding methods on the singleton, and directly accessing hash values on the singleton. A new version has been released that uses the Test2 API to accomplish the same result in a saner way. Fixed in version: 0.07 =item Test::Dist::VersionSync This had Test::Builder2 conditionals. This was fixed by removing the conditionals. Fixed in version: 1.1.4 =item Test::Modern This relied on C<< Test::Builder->_try() >> which was a private method, documented as something nobody should use. This was fixed by using a different tool. Fixed in version: 0.012 =item Test::UseAllModules Version 0.14 relied on C<< Test::Builder->history >> which was available in Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder internals. Fixed in version: 0.15 =item Test::More::Prefix Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>. Fixed by adding an event filter that modifies the message instead when running under Test2. Fixed in version: 0.007 =back =head2 STILL BROKEN =over 4 =item Test::Aggregate This distribution directly accesses the hash keys in the L singleton. It also approaches the problem from the wrong angle, please consider using L or L which both solve the same problem at the harness level. Still broken as of version: 0.373 =item Test::Wrapper This module directly uses hash keys in the L singleton. This module is also obsolete thanks to the benefits of L. Use C from L to achieve a similar result. Still broken as of version: 0.3.0 =item Test::ParallelSubtest This module overrides C and C. It also directly accesses hash elements of the singleton. It has not yet been fixed. Alternatives: L and L (not stable). Still broken as of version: 0.05 =item Test::Pretty See https://github.com/tokuhirom/Test-Pretty/issues/25 The author admits the module is crazy, and he is awaiting a stable release of something new (Test2) to completely rewrite it in a sane way. Still broken as of version: 0.32 =item Net::BitTorrent The tests for this module directly access L hash keys. Most, if not all of these hash keys have public API methods that could be used instead to avoid the problem. Still broken in version: 0.052 =item Test::Group It monkeypatches Test::Builder, and calls it "black magic" in the code. Still broken as of version: 0.20 =item Test::Flatten This modifies the Test::Builder internals in many ways. A better was to accomplish the goal of this module is to write your own subtest function. Still broken as of version: 0.11 =item Log::Dispatch::Config::TestLog Modifies Test::Builder internals. Still broken as of version: 0.02 =item Test::Able Modifies Test::Builder internals. Still broken as of version: 0.11 =back =head1 MAKE ASSERTIONS -> SEND EVENTS =head2 LEGACY use Test::Builder; # A majority of tools out there do this: # my $TB = Test::Builder->new; # This works, but has always been wrong, forcing Test::Builder to implement # subtests as a horrific hack. It also causes problems for tools that try # to replace the singleton (also discouraged). sub my_ok($;$) { my ($bool, $name) = @_; my $TB = Test::Builder->new; $TB->ok($bool, $name); } sub my_diag($) { my ($msg) = @_; my $TB = Test::Builder->new; $TB->diag($msg); } =head2 TEST2 use Test2::API qw/context/; sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } sub my_diag($) { my ($msg) = @_; my $ctx = context(); $ctx->diag($msg); $ctx->release; } The context object has API compatible implementations of the following methods: =over 4 =item ok($bool, $name) =item diag(@messages) =item note(@messages) =item subtest($name, $code) =back If you are looking for helpers with C, C, and others, see L. =head1 WRAP EXISTING TOOLS =head2 LEGACY use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Ensure errors are reported 1 level higher local $Test::Builder::Level = $Test::Builder::Level + 1; $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); return $bool; } Every single tool in the chain from this, to C, to anything C calls needs to increment the C<$Level> variable. When an error occurs Test::Builder will do a trace to the stack frame determined by C<$Level>, and report that file+line as the one where the error occurred. If you or any other tool you use forgets to set C<$Level> then errors will be reported to the wrong place. =head2 TEST2 use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Grab and store the context, even if you do not need to use it # directly. my $ctx = context(); $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); $ctx->release; return $bool; } Instead of using C<$Level> to perform a backtrace, Test2 uses a context object. In this sample you create a context object and store it. This locks the context (errors report 1 level up from here) for all wrapped tools to find. You do not need to use the context object, but you do need to store it in a variable. Once the sub ends the C<$ctx> variable is destroyed which lets future tools find their own. =head1 USING UTF8 =head2 LEGACY # Set the mode BEFORE anything loads Test::Builder use open ':std', ':encoding(utf8)'; use Test::More; Or # Modify the filehandles my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; =head2 TEST2 use Test2::API qw/test2_stack/; test2_stack->top->format->encoding('utf8'); Though a much better way is to use the L plugin, which is part of L. =head1 AUTHORS, CONTRIBUTORS AND REVIEWERS The following people have all contributed to this document in some way, even if only for review. =over 4 =item Chad Granum (EXODIST) Eexodist@cpan.orgE =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINER =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Tools/0000755000175000017500000000000013243466361016714 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Tools/Tiny.pm0000644000175000017500000002166513243466361020207 0ustar exodistexodistpackage Test2::Tools::Tiny; use strict; use warnings; BEGIN { if ($] lt "5.008") { require Test::Builder::IO::Scalar; } } use Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); our $VERSION = '1.302125'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing warnings exception tests capture }; sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" eq "$want"; } elsif (defined($got) xor defined($want)) { $bool = 0; } else { # Both are undef $bool = 1; } return $ctx->pass_and_release($name) if $bool; $got = '*NOT DEFINED*' unless defined $got; $want = '*NOT DEFINED*' unless defined $want; unshift @diag => ( "GOT: $got", "EXPECTED: $want", ); return $ctx->fail_and_release($name, @diag); } sub isnt($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" ne "$want"; } elsif (defined($got) xor defined($want)) { $bool = 1; } else { # Both are undef $bool = 0; } return $ctx->pass_and_release($name) if $bool; unshift @diag => "Strings are the same (they should not be)" unless $bool; return $ctx->fail_and_release($name, @diag); } sub like($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" =~ $pattern; unshift @diag => ( "Value: $thing", "Does not match: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub unlike($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" !~ $pattern; unshift @diag => ( "Unexpected pattern match (it should not match)", "Value: $thing", "Matches: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is_deeply($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); no warnings 'once'; require Data::Dumper; # Otherwise numbers might be unquoted local $Data::Dumper::Useperl = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Freezer = 'XXX'; local *UNIVERSAL::XXX = sub { my ($thing) = @_; if (ref($thing)) { $thing = {%$thing} if "$thing" =~ m/=HASH/; $thing = [@$thing] if "$thing" =~ m/=ARRAY/; $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; } $_[0] = $thing; }; my $g = Data::Dumper::Dumper($got); my $w = Data::Dumper::Dumper($want); my $bool = $g eq $w; return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, $g, $w, @diag); } sub diag { my $ctx = context(); $ctx->diag(join '', @_); $ctx->release; } sub note { my $ctx = context(); $ctx->note(join '', @_); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub todo { my ($reason, $sub) = @_; my $ctx = context(); # This code is mostly copied from Test2::Todo in the Test2-Suite # distribution. my $hub = test2_stack->top; my $filter = $hub->pre_filter( sub { my ($active_hub, $event) = @_; if ($active_hub == $hub) { $event->set_todo($reason) if $event->can('set_todo'); $event->add_amnesty({tag => 'TODO', details => $reason}); } else { $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1}); } return $event; }, inherit => 1, todo => $reason, ); $sub->(); $hub->pre_unfilter($filter); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } sub tests { my ($name, $code) = @_; my $ctx = context(); my $be = caller->can('before_each'); $be->($name) if $be; my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my $handles = test2_stack->top->format->handles; my ($ok, $e); { my ($out_fh, $err_fh); ($ok, $e) = try { # Scalar refs as filehandles were added in 5.8. if ($] ge "5.008") { open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; } # Emulate scalar ref filehandles with a tie. else { $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT"; $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR"; } test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); $code->(); }; } test2_stack->top->format->set_handles($handles); die $e unless $ok; $err =~ s/ $/_/mg; $out =~ s/ $/_/mg; return { STDOUT => $out, STDERR => $err, }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use L. =head1 DESCRIPTION You should really look at L. This package is some very basic essential tools implemented using L. This exists only so that L and other tools required by L can be tested. This is the package L uses to test itself. =head1 USE Test2::Suite INSTEAD Use L if at all possible. =head1 EXPORTS =over 4 =item ok($bool, $name) =item ok($bool, $name, @diag) Run a simple assertion. =item is($got, $want, $name) =item is($got, $want, $name, @diag) Assert that 2 strings are the same. =item isnt($got, $do_not_want, $name) =item isnt($got, $do_not_want, $name, @diag) Assert that 2 strings are not the same. =item like($got, $regex, $name) =item like($got, $regex, $name, @diag) Check that the input string matches the regex. =item unlike($got, $regex, $name) =item unlike($got, $regex, $name, @diag) Check that the input string does not match the regex. =item is_deeply($got, $want, $name) =item is_deeply($got, $want, $name, @diag) Check 2 data structures. Please note that this is a I implementation that compares the output of L against both structures. =item diag($msg) Issue a diagnostics message to STDERR. =item note($msg) Issue a diagnostics message to STDOUT. =item skip_all($reason) Skip all tests. =item todo $reason => sub { ... } Run a block in TODO mode. =item plan($count) Set the plan. =item done_testing() Set the plan to the current test count. =item $warnings = warnings { ... } Capture an arrayref of warnings from the block. =item $exception = exception { ... } Capture an exception. =item tests $name => sub { ... } Run a subtest. =item $output = capture { ... } Capture STDOUT and STDERR output. Result looks like this: { STDOUT => "...", STDERR => "...", } =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/IPC/0000755000175000017500000000000013243466361016227 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/IPC/Driver/0000755000175000017500000000000013243466361017462 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/IPC/Driver/Files.pm0000644000175000017500000003105613243466361021067 0ustar exodistexodistpackage Test2::IPC::Driver::Files; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals}; use Scalar::Util qw/blessed/; use File::Temp(); use Storable(); use File::Spec(); use POSIX(); use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/; use Test2::API qw/test2_ipc_set_pending/; sub use_shm { 1 } sub shm_size() { 64 } sub is_viable { 1 } sub init { my $self = shift; my $tmpdir = File::Temp::tempdir( $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", CLEANUP => 0, TMPDIR => 1, ); $self->abort_trace("Could not get a temp dir") unless $tmpdir; $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); print STDERR "\nIPC Temp Dir: $tmpdir\n\n" if $ENV{T2_KEEP_TEMPDIR}; $self->{+EVENT_IDS} = {}; $self->{+READ_IDS} = {}; $self->{+TIMEOUTS} = {}; $self->{+TID} = get_tid(); $self->{+PID} = $$; $self->{+GLOBALS} = {}; return $self; } sub hub_file { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); } sub event_file { my $self = shift; my ($hid, $e) = @_; my $tempdir = $self->{+TEMPDIR}; my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); $self->abort("'$e' is not an event object!") unless $type->isa('Test2::Event'); my $tid = get_tid(); my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1; my @type = split '::', $type; my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type); return File::Spec->catfile($tempdir, $name); } sub add_hub { my $self = shift; my ($hid) = @_; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' already exists") if -e $hfile; open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); print $fh "$$\n" . get_tid() . "\n"; close($fh); } sub drop_hub { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' does not exist") unless -e $hfile; open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); my ($pid, $tid) = <$fh>; close($fh); $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") unless $pid == $$; $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) unless get_tid() == $tid; if ($ENV{T2_KEEP_TEMPDIR}) { my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok } else { my ($ok, $err) = do_unlink($hfile); $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok } opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); for my $file (readdir($dh)) { next if $file =~ m{\.complete$}; next unless $file =~ m{^$hid}; $self->abort_trace("Not all files from hub '$hid' have been collected!"); } closedir($dh); } sub send { my $self = shift; my ($hid, $e, $global) = @_; my $tempdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); my $dest = $global ? 'GLOBAL' : $hid; $self->abort(<<" EOT") unless $global || -f $hfile; hub '$hid' is not available, failed to send event! There was an attempt to send an event to a hub in a parent process or thread, but that hub appears to be gone. This can happen if you fork, or start a new thread from inside subtest, and the parent finishes the subtest before the child returns. This can also happen if the parent process is done testing before the child finishes. Test2 normally waits automatically in the root process, but will not do so if Test::Builder is loaded for legacy reasons. EOT my $file = $self->event_file($dest, $e); my $ready = File::Spec->canonpath("$file.ready"); if ($global) { my $name = $ready; $name =~ s{^.*(GLOBAL)}{GLOBAL}; $self->{+GLOBALS}->{$hid}->{$name}++; } # Write and rename the file. my ($ren_ok, $ren_err); my ($ok, $err) = try_sig_mask { Storable::store($e, $file); ($ren_ok, $ren_err) = do_rename("$file", $ready); }; if ($ok) { $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; test2_ipc_set_pending(substr($file, -(shm_size))); } else { my $src_file = __FILE__; $err =~ s{ at \Q$src_file\E.*$}{}; chomp($err); my $tid = get_tid(); my $trace = $e->trace->debug; my $type = blessed($e); $self->abort(<<" EOT"); ******************************************************************************* There was an error writing an event: Destination: $dest Origin PID: $$ Origin TID: $tid Event Type: $type Event Trace: $trace File Name: $file Ready Name: $ready Error: $err ******************************************************************************* EOT } return 1; } sub driver_abort { my $self = shift; my ($msg) = @_; local ($@, $!, $?, $^E); eval { my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); open(my $fh, '>>', $abort) or die "Could not open abort file: $!"; print $fh $msg, "\n"; close($fh) or die "Could not close abort file: $!"; 1; } or warn $@; } sub cull { my $self = shift; my ($hid) = @_; my $tempdir = $self->{+TEMPDIR}; opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); my $read = $self->{+READ_IDS}; my $timeouts = $self->{+TIMEOUTS}; my @out; for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { unless ($info->{global}) { my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1; $timeouts->{$info->{file}} ||= time; if ($next != $info->{eid}) { # Wait up to N seconds for missing events next unless 5 < time - $timeouts->{$info->{file}}; $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}."); } $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1; } my $full = $info->{full_path}; my $obj = $self->read_event_file($full); push @out => $obj; # Do not remove global events next if $info->{global}; if ($ENV{T2_KEEP_TEMPDIR}) { my $complete = File::Spec->canonpath("$full.complete"); my ($ok, $err) = do_rename($full, $complete); $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; } else { my ($ok, $err) = do_unlink("$full"); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; } } closedir($dh); return @out; } sub parse_event_filename { my $self = shift; my ($file) = @_; # The || is to force 0 in false my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); my @parts = split ipc_separator, $file; my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 3)); my ($pid, $tid, $eid) = splice(@parts, 0, 3); my $type = join '::' => @parts; return { file => $file, ready => $ready, complete => $complete, global => $global, type => $type, hid => $hid, pid => $pid, tid => $tid, eid => $eid, }; } sub should_read_event { my $self = shift; my ($hid, $file) = @_; return if substr($file, 0, 1) eq '.'; return if substr($file, 0, 3) eq 'HUB'; CORE::exit(255) if $file eq 'ABORT'; my $parsed = $self->parse_event_filename($file); return if $parsed->{complete}; return unless $parsed->{ready}; return unless $parsed->{global} || $parsed->{hid} eq $hid; return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; # Untaint the path. my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; $parsed->{full_path} = $full; return $parsed; } sub cmp_events { # Globals first return -1 if $a->{global} && !$b->{global}; return 1 if $b->{global} && !$a->{global}; return $a->{pid} <=> $b->{pid} || $a->{tid} <=> $b->{tid} || $a->{eid} <=> $b->{eid}; } sub read_event_file { my $self = shift; my ($file) = @_; my $obj = Storable::retrieve($file); $self->abort("Got an unblessed object: '$obj'") unless blessed($obj); unless ($obj->isa('Test2::Event')) { my $pkg = blessed($obj); my $mod_file = pkg_to_file($pkg); my ($ok, $err) = try { require $mod_file }; $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") unless $ok; $self->abort("'$obj' is not a 'Test2::Event' object") unless $obj->isa('Test2::Event'); } return $obj; } sub waiting { my $self = shift; require Test2::Event::Waiting; $self->send( GLOBAL => Test2::Event::Waiting->new( trace => Test2::EventFacet::Trace->new(frame => [caller()]), ), 'GLOBAL' ); return; } sub DESTROY { my $self = shift; return unless defined $self->pid; return unless defined $self->tid; return unless $$ == $self->pid; return unless get_tid() == $self->tid; my $tempdir = $self->{+TEMPDIR}; my $aborted = 0; my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); if (-e $abort_file) { $aborted = 1; my ($ok, $err) = do_unlink($abort_file); warn $err unless $ok; } opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); while(my $file = readdir($dh)) { next if $file =~ m/^\.+$/; next if $file =~ m/\.complete$/; my $full = File::Spec->catfile($tempdir, $file); my $sep = ipc_separator; if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) { $full =~ m/^(.*)$/; $full = $1; # Untaint it next if $ENV{T2_KEEP_TEMPDIR}; my ($ok, $err) = do_unlink($full); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; next; } $self->abort("Leftover files in the directory ($full)!\n"); } closedir($dh); if ($ENV{T2_KEEP_TEMPDIR}) { print STDERR "# Not removing temp dir: $tempdir\n"; return; } my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); unlink($abort) if -e $abort; rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver::Files - Temp dir + Files concurrency model. =head1 DESCRIPTION This is the default, and fallback concurrency model for L. This sends events between processes and threads using serialized files in a temporary directory. This is not particularly fast, but it works everywhere. =head1 SYNOPSIS use Test2::IPC::Driver::Files; # IPC is now enabled =head1 ENVIRONMENT VARIABLES =over 4 =item T2_KEEP_TEMPDIR=0 When true, the tempdir used by the IPC driver will not be deleted when the test is done. =item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' This can be used to set the template for the IPC temp dir. The template should follow template specifications from L. =back =head1 SEE ALSO See L for methods. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/IPC/Driver.pm0000644000175000017500000001557513243466361020035 0ustar exodistexodistpackage Test2::IPC::Driver; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/confess/; use Test2::Util::HashBase qw{no_fatal no_bail}; use Test2::API qw/test2_ipc_add_driver/; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; test2_ipc_add_driver($class); } sub use_shm { 0 } for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { no strict 'refs'; *$meth = sub { my $thing = shift; confess "'$thing' did not define the required method '$meth'." }; } # Print the error and call exit. We are not using 'die' cause this is a # catastrophic error that should never be caught. If we get here it # means some serious shit has happened in a child process, the only way # to inform the parent may be to exit false. sub abort { my $self = shift; chomp(my ($msg) = @_); $self->driver_abort($msg) if $self->can('driver_abort'); print STDERR "IPC Fatal Error: $msg\n"; print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; CORE::exit(255) unless $self->no_fatal; } sub abort_trace { my $self = shift; my ($msg) = @_; # Older versions of Carp do not export longmess() function, so it needs to be called with package name $self->abort(Carp::longmess($msg)); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver - Base class for Test2 IPC drivers. =head1 SYNOPSIS package Test2::IPC::Driver::MyDriver; use base 'Test2::IPC::Driver'; ... =head1 METHODS =over 4 =item $self->abort($msg) If an IPC encounters a fatal error it should use this. This will print the message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will forcefully exit 255. IPC errors may occur in threads or processes other than the main one, this method provides the best chance of the harness noticing the error. =item $self->abort_trace($msg) This is the same as C<< $ipc->abort($msg) >> except that it uses C to add a stack trace to the message. =item $false = $self->use_shm The base class always returns false for this method. You may override it if you wish to use the SHM made available in L/L. =back =head1 LOADING DRIVERS Test2::IPC::Driver has an C method. All drivers inherit this import method. This import method registers the driver. In most cases you just need to load the desired IPC driver to make it work. You should load this driver as early as possible. A warning will be issued if you load it too late for it to be effective. use Test2::IPC::Driver::MyDriver; ... =head1 WRITING DRIVERS package Test2::IPC::Driver::MyDriver; use strict; use warnings; use base 'Test2::IPC::Driver'; sub is_viable { return 0 if $^O eq 'win32'; # Will not work on windows. return 1; } sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } sub send { my $self = shift; my ($hid, $e, $global) = @_; ... # Send the event to the proper hub. # If you are using the SHM you should notify other procs/threads that # there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } 1; =head2 METHODS SUBCLASSES MUST IMPLEMENT =over 4 =item $ipc->is_viable This should return true if the driver works in the current environment. This should return false if it does not. This is a CLASS method. =item $ipc->add_hub($hid) This is used to alert the driver that a new hub is expecting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it. sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } =item $ipc->drop_hub($hid) This is used to alert the driver that a hub is no longer accepting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it (This is the drivers responsibility to enforce). sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } =item $ipc->send($hid, $event); =item $ipc->send($hid, $event, $global); Used to send events from the current process/thread to the specified hub in its process+thread. sub send { my $self = shift; my ($hid, $e) = @_; ... # Send the event to the proper hub. # If you are using the SHM you should notify other procs/threads that # there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } If C<$global> is true then the driver should send the event to all hubs in all processes and threads. =item @events = $ipc->cull($hid) Used to collect events that have been sent to the specified hub. sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } =item $ipc->waiting() This is called in the parent process when it is complete and waiting for all child processes and threads to complete. sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } =back =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE =over 4 =item $ipc->driver_abort($msg) This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your chance to cleanup when an abort happens. You cannot prevent the abort, but you can gracefully except it. =item $bool = $ipc->use_shm() True if you want to make use of the L/L SHM. =item $bites = $ipc->shm_size() Use this to customize the size of the SHM space. There are no guarantees about what the size will be if you do not implement this. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Util/0000755000175000017500000000000013243466361016531 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Util/Facets2Legacy.pm0000644000175000017500000000545513243466361021514 0ustar exodistexodistpackage Test2::Util::Facets2Legacy; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/croak confess/; use Scalar::Util qw/blessed/; use base 'Exporter'; our @EXPORT_OK = qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate }; our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); our $CYCLE_DETECT = 0; sub _get_facet_data { my $in = shift; if (blessed($in) && $in->isa('Test2::Event')) { confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" if $CYCLE_DETECT; local $CYCLE_DETECT = 1; return $in->facet_data; } return $in if ref($in) eq 'HASH'; croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; } sub causes_fail { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; if (my $control = $facet_data->{control}) { return 1 if $control->{halt}; return 1 if $control->{terminate}; } return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; return 0; } sub diagnostics { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; return 0 unless $facet_data->{info} && @{$facet_data->{info}}; return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; } sub global { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{control}; return $facet_data->{control}->{global}; } sub increments_count { my $facet_data = _get_facet_data(shift @_); return $facet_data->{assert} ? 1 : 0; } sub no_display { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{about}; return $facet_data->{about}->{no_display}; } sub sets_plan { my $facet_data = _get_facet_data(shift @_); my $plan = $facet_data->{plan} or return; my @out = ($plan->{count} || 0); if ($plan->{skip}) { push @out => 'SKIP'; push @out => $plan->{details} if defined $plan->{details}; } elsif ($plan->{none}) { push @out => 'NO PLAN' } return @out; } sub subtest_id { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{parent}; return $facet_data->{parent}->{hid}; } sub summary { my $facet_data = _get_facet_data(shift @_); return '' unless $facet_data->{about} && $facet_data->{about}->{details}; return $facet_data->{about}->{details}; } sub terminate { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{control}; return $facet_data->{control}->{terminate}; } 1; Test-Simple-1.302125/lib/Test2/Util/ExternalMeta.pm0000644000175000017500000000730313243466361021463 0ustar exodistexodistpackage Test2::Util::ExternalMeta; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/croak/; sub META_KEY() { '_meta' } our @EXPORT = qw/meta set_meta get_meta delete_meta/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub set_meta { my $self = shift; my ($key, $value) = @_; validate_key($key); $self->{+META_KEY} ||= {}; $self->{+META_KEY}->{$key} = $value; } sub get_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; return $meta->{$key}; } sub delete_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; delete $meta->{$key}; } sub meta { my $self = shift; my ($key, $default) = @_; validate_key($key); my $meta = $self->{+META_KEY}; return undef unless $meta || defined($default); unless($meta) { $meta = {}; $self->{+META_KEY} = $meta; } $meta->{$key} = $default if defined($default) && !defined($meta->{$key}); return $meta->{$key}; } sub validate_key { my $key = shift; return if $key && !ref($key); my $render_key = defined($key) ? "'$key'" : 'undef'; croak "Invalid META key: $render_key, keys must be true, and may not be references"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data to your instances. =head1 DESCRIPTION This package lets you define a clear, and consistent way to allow third party tools to attach meta-data to your instances. If your object consumes this package, and imports its methods, then third party meta-data has a safe place to live. =head1 SYNOPSIS package My::Object; use strict; use warnings; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; ... Now to use it: my $inst = My::Object->new; $inst->set_meta(foo => 'bar'); my $val = $inst->get_meta('foo'); =head1 WHERE IS THE DATA STORED? This package assumes your instances are blessed hashrefs, it will not work if that is not true. It will store all meta-data in the C<_meta> key on your objects hash. If your object makes use of the C<_meta> key in its underlying hash, then there is a conflict and you cannot use this package. =head1 EXPORTS =over 4 =item $val = $obj->meta($key) =item $val = $obj->meta($key, $default) This will get the value for a specified meta C<$key>. Normally this will return C when there is no value for the C<$key>, however you can specify a C<$default> value to set when no value is already set. =item $val = $obj->get_meta($key) This will get the value for a specified meta C<$key>. This does not have the C<$default> overhead that C does. =item $val = $obj->delete_meta($key) This will remove the value of a specified meta C<$key>. The old C<$val> will be returned. =item $obj->set_meta($key, $val) Set the value of a specified meta C<$key>. =back =head1 META-KEY RESTRICTIONS Meta keys must be defined, and must be true when used as a boolean. Keys may not be references. You are free to stringify a reference C<"$ref"> for use as a key, but this package will not stringify it for you. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Util/HashBase.pm0000644000175000017500000002671213243466361020555 0ustar exodistexodistpackage Test2::Util::HashBase; use strict; use warnings; our $VERSION = '1.302125'; ################################################################# # # # This is a generated file! Do not modify this file directly! # # Use hashbase_inc.pl script to regenerate this file. # # The script is part of the Object::HashBase distribution. # # Note: You can modify the version number above this comment # # if needed, that is fine. # # # ################################################################# { no warnings 'once'; $Test2::Util::HashBase::HB_VERSION = '0.006'; *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; } require Carp; { no warnings 'once'; $Carp::Internal{+__PACKAGE__} = 1; } BEGIN { # these are not strictly equivalent, but for out use we don't care # about order *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { no strict 'refs'; my @packages = ($_[0]); my %seen; for my $package (@packages) { push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; } return \@packages; } } my %STRIP = ( '^' => 1, '-' => 1, ); sub import { my $class = shift; my $into = caller; # Make sure we list the OLDEST version used to create this class. my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION; $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver; my $isa = _isa($into); my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= []; my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; my %subs = ( ($into->can('new') ? () : (new => \&_new)), (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), ( map { my $p = substr($_, 0, 1); my $x = $_; substr($x, 0, 1) = '' if $STRIP{$p}; push @$attr_list => $x; my ($sub, $attr) = (uc $x, $x); $sub => ($attr_subs->{$sub} = sub() { $attr }), $attr => sub { $_[0]->{$attr} }, $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), } @_ ), ); no strict 'refs'; *{"$into\::$_"} = $subs{$_} for keys %subs; } sub attr_list { my $class = shift; my $isa = _isa($class); my %seen; my @list = grep { !$seen{$_}++ } map { my @out; if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); } else { my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; @out = $list ? @$list : () } @out; } reverse @$isa; return @list; } sub _new { my $class = shift; my $self; if (@_ == 1) { my $arg = shift; my $type = ref($arg); if ($type eq 'HASH') { $self = bless({%$arg}, $class) } else { Carp::croak("Not sure what to do with '$type' in $class constructor") unless $type eq 'ARRAY'; my %proto; my @attributes = attr_list($class); while (@$arg) { my $val = shift @$arg; my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); $proto{$key} = $val; } $self = bless(\%proto, $class); } } else { $self = bless({@_}, $class); } $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::HashBase - Build hash based classes. =head1 SYNOPSIS A class: package My::Class; use strict; use warnings; # Generate 3 accessors use Test2::Util::HashBase qw/foo -bar ^baz/; # Chance to initialize defaults sub init { my $self = shift; # No other args $self->{+FOO} ||= "foo"; $self->{+BAR} ||= "bar"; $self->{+BAZ} ||= "baz"; } sub print { print join ", " => map { $self->{$_} } FOO, BAR, BAZ; } Subclass it package My::Subclass; use strict; use warnings; # Note, you should subclass before loading HashBase. use base 'My::Class'; use Test2::Util::HashBase qw/bat/; sub init { my $self = shift; # We get the constants from the base class for free. $self->{+FOO} ||= 'SubFoo'; $self->{+BAT} ||= 'bat'; $self->SUPER::init(); } use it: package main; use strict; use warnings; use My::Class; # These are all functionally identical my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); my $three = My::Class->new(['MyFoo', 'MyBar']); # Accessors! my $foo = $one->foo; # 'MyFoo' my $bar = $one->bar; # 'MyBar' my $baz = $one->baz; # Defaulted to: 'baz' # Setters! $one->set_foo('A Foo'); #'-bar' means read-only, so the setter will throw an exception (but is defined). $one->set_bar('A bar'); # '^baz' means deprecated setter, this will warn about the setter being # deprecated. $one->set_baz('A Baz'); $one->{+FOO} = 'xxx'; =head1 DESCRIPTION This package is used to generate classes based on hashrefs. Using this class will give you a C method, as well as generating accessors you request. Generated accessors will be getters, C setters will also be generated for you. You also get constants for each accessor (all caps) which return the key into the hash for that accessor. Single inheritance is also supported. =head1 THIS IS A BUNDLED COPY OF HASHBASE This is a bundled copy of L. This file was generated using the C script. =head1 METHODS =head2 PROVIDED BY HASH BASE =over 4 =item $it = $class->new(%PAIRS) =item $it = $class->new(\%PAIRS) =item $it = $class->new(\@ORDERED_VALUES) Create a new instance. HashBase will not export C if there is already a C method in your packages inheritance chain. B you just have to declare it before loading L. package My::Package; # predeclare new() so that HashBase does not give us one. sub new; use Test2::Util::HashBase qw/foo bar baz/; # Now we define our own new method. sub new { ... } This makes it so that HashBase sees that you have your own C method. Alternatively you can define the method before loading HashBase instead of just declaring it, but that scatters your use statements. The most common way to create an object is to pass in key/value pairs where each key is an attribute and each value is what you want assigned to that attribute. No checking is done to verify the attributes or values are valid, you may do that in C if desired. If you would like, you can pass in a hashref instead of pairs. When you do so the hashref will be copied, and the copy will be returned blessed as an object. There is no way to ask HashBase to bless a specific hashref. In some cases an object may only have 1 or 2 attributes, in which case a hashref may be too verbose for your liking. In these cases you can pass in an arrayref with only values. The values will be assigned to attributes in the order the attributes were listed. When there is inheritance involved the attributes from parent classes will come before subclasses. =back =head2 HOOKS =over 4 =item $self->init() This gives you the chance to set some default values to your fields. The only argument is C<$self> with its indexes already set from the constructor. B Test2::Util::HashBase checks for an init using C<< $class->can('init') >> during construction. It DOES NOT call C on the created object. Also note that the result of the check is cached, it is only ever checked once, the first time an instance of your class is created. This means that adding an C method AFTER the first construction will result in it being ignored. =back =head1 ACCESSORS =head2 READ/WRITE To generate accessors you list them when using the module: use Test2::Util::HashBase qw/foo/; This will generate the following subs in your namespace: =over 4 =item foo() Getter, used to get the value of the C field. =item set_foo() Setter, used to set the value of the C field. =item FOO() Constant, returns the field C's key into the class hashref. Subclasses will also get this function as a constant, not simply a method, that means it is copied into the subclass namespace. The main reason for using these constants is to help avoid spelling mistakes and similar typos. It will not help you if you forget to prefix the '+' though. =back =head2 READ ONLY use Test2::Util::HashBase qw/-foo/; =over 4 =item set_foo() Throws an exception telling you the attribute is read-only. This is exported to override any active setters for the attribute in a parent class. =back =head2 DEPRECATED SETTER use Test2::Util::HashBase qw/^foo/; =over 4 =item set_foo() This will set the value, but it will also warn you that the method is deprecated. =back =head1 SUBCLASSING You can subclass an existing HashBase class. use base 'Another::HashBase::Class'; use Test2::Util::HashBase qw/foo bar baz/; The base class is added to C<@ISA> for you, and all constants from base classes are added to subclasses automatically. =head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS Test2::Util::HashBase provides a function for retrieving a list of attributes for an Test2::Util::HashBase class. =over 4 =item @list = Test2::Util::HashBase::attr_list($class) =item @list = $class->Test2::Util::HashBase::attr_list() Either form above will work. This will return a list of attributes defined on the object. This list is returned in the attribute definition order, parent class attributes are listed before subclass attributes. Duplicate attributes will be removed before the list is returned. B This list is used in the C<< $class->new(\@ARRAY) >> constructor to determine the attribute to which each value will be paired. =back =head1 SOURCE The source code repository for HashBase can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Util/Trace.pm0000644000175000017500000000152313243466361020126 0ustar exodistexodistpackage Test2::Util::Trace; require Test2::EventFacet::Trace; @ISA = ('Test2::EventFacet::Trace'); our $VERSION = '1.302125'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Trace - Legacy wrapper fro L. =head1 DESCRIPTION All the functionality for this class has been moved to L. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/EventFacet.pm0000644000175000017500000000272613243466361020205 0ustar exodistexodistpackage Test2::EventFacet; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Util::HashBase qw/-details/; use Carp qw/croak/; my $SUBLEN = length(__PACKAGE__ . '::'); sub facet_key { my $key = ref($_[0]) || $_[0]; substr($key, 0, $SUBLEN, ''); return lc($key); } sub is_list { 0 } sub clone { my $self = shift; my $type = ref($self); return bless {%$self, @_}, $type; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet - Base class for all event facets. =head1 DESCRIPTION Base class for all event facets. =head1 METHODS =over 4 =item $key = $facet_class->facet_key() This will return the key for the facet in the facet data hash. =item $bool = $facet_class->is_list() This will return true if the facet should be in a list instead of a single item. =item $clone = $facet->clone() =item $clone = $facet->clone(%replace) This will make a shallow clone of the facet. You may specify fields to override as arguments. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/API/0000755000175000017500000000000013243466361016225 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/API/Breakage.pm0000644000175000017500000001120413243466361020262 0ustar exodistexodistpackage Test2::API::Breakage; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Util qw/pkg_to_file/; our @EXPORT_OK = qw{ upgrade_suggested upgrade_required known_broken }; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub upgrade_suggested { return ( 'Test::Exception' => '0.42', 'Test::FITesque' => '0.04', 'Test::Module::Used' => '0.2.5', 'Test::Moose::More' => '0.025', ); } sub upgrade_required { return ( 'Test::Builder::Clutch' => '0.07', 'Test::Dist::VersionSync' => '1.1.4', 'Test::Modern' => '0.012', 'Test::SharedFork' => '0.34', 'Test::Alien' => '0.04', 'Test::UseAllModules' => '0.14', 'Test::More::Prefix' => '0.005', 'Test2::Tools::EventDumper' => 0.000007, 'Test2::Harness' => 0.000013, 'Test::DBIx::Class::Schema' => '1.0.9', 'Test::Clustericious::Cluster' => '0.30', ); } sub known_broken { return ( 'Net::BitTorrent' => '0.052', 'Test::Able' => '0.11', 'Test::Aggregate' => '0.373', 'Test::Flatten' => '0.11', 'Test::Group' => '0.20', 'Test::ParallelSubtest' => '0.05', 'Test::Pretty' => '0.32', 'Test::Wrapper' => '0.3.0', 'Log::Dispatch::Config::TestLog' => '0.02', ); } # Not reportable: # Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. sub report { my $class = shift; my ($require) = @_; my %suggest = __PACKAGE__->upgrade_suggested(); my %required = __PACKAGE__->upgrade_required(); my %broken = __PACKAGE__->known_broken(); my @warn; for my $mod (keys %suggest) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $suggest{$mod}; next if eval { $mod->VERSION($want); 1 }; push @warn => " * Module '$mod' is outdated, we recommed updating above $want."; } for my $mod (keys %required) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $required{$mod}; next if eval { $mod->VERSION($want); 1 }; push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; } for my $mod (keys %broken) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $tested = $broken{$mod}; push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; } return @warn; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Breakage - What breaks at what version =head1 DESCRIPTION This module provides lists of modules that are broken, or have been broken in the past, when upgrading L to use L. =head1 FUNCTIONS These can be imported, or called as methods on the class. =over 4 =item %mod_ver = upgrade_suggested() =item %mod_ver = Test2::API::Breakage->upgrade_suggested() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade would be a good idea, but not strictly necessary. =item %mod_ver = upgrade_required() =item %mod_ver = Test2::API::Breakage->upgrade_required() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade is required for the module to work properly. =item %mod_ver = known_broken() =item %mod_ver = Test2::API::Breakage->known_broken() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then the module will not work. A newer version may work, but is not tested or verified. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/API/Instance.pm0000644000175000017500000005612313243466361020336 0ustar exodistexodistpackage Test2::API::Instance; use strict; use warnings; our $VERSION = '1.302125'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; use Scalar::Util qw/reftype/; use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/; use Test2::EventFacet::Trace(); use Test2::API::Stack(); use Test2::Util::HashBase qw{ _pid _tid no_wait finalized loaded ipc stack formatter contexts -preload ipc_disabled ipc_shm_size ipc_shm_last ipc_shm_id ipc_polling ipc_drivers ipc_timeout formatters exit_callbacks post_load_callbacks context_acquire_callbacks context_init_callbacks context_release_callbacks pre_subtest_callbacks }; sub DEFAULT_IPC_TIMEOUT() { 30 } sub pid { $_[0]->{+_PID} } sub tid { $_[0]->{+_TID} } # Wrap around the getters that should call _finalize. BEGIN { for my $finalizer (IPC, FORMATTER) { my $orig = __PACKAGE__->can($finalizer); my $new = sub { my $self = shift; $self->_finalize unless $self->{+FINALIZED}; $self->$orig; }; no strict 'refs'; no warnings 'redefine'; *{$finalizer} = $new; } } sub has_ipc { !!$_[0]->{+IPC} } sub import { my $class = shift; return unless @_; my ($ref) = @_; $$ref = $class->new; } sub init { $_[0]->reset } sub start_preload { my $self = shift; confess "preload cannot be started, Test2::API has already been initialized" if $self->{+FINALIZED} || $self->{+LOADED}; return $self->{+PRELOAD} = 1; } sub stop_preload { my $self = shift; return 0 unless $self->{+PRELOAD}; $self->{+PRELOAD} = 0; $self->post_preload_reset(); return 1; } sub post_preload_reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+CONTEXTS} = {}; $self->{+FORMATTERS} = []; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+LOADED} = 0; $self->{+STACK} ||= Test2::API::Stack->new; } sub reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+CONTEXTS} = {}; $self->{+IPC_DRIVERS} = []; $self->{+IPC_POLLING} = undef; $self->{+FORMATTERS} = []; $self->{+FORMATTER} = undef; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+NO_WAIT} = 0; $self->{+LOADED} = 0; $self->{+EXIT_CALLBACKS} = []; $self->{+POST_LOAD_CALLBACKS} = []; $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; $self->{+CONTEXT_INIT_CALLBACKS} = []; $self->{+CONTEXT_RELEASE_CALLBACKS} = []; $self->{+PRE_SUBTEST_CALLBACKS} = []; $self->{+STACK} = Test2::API::Stack->new; } sub _finalize { my $self = shift; my ($caller) = @_; $caller ||= [caller(1)]; confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+FINALIZED} = $caller; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; unless ($self->{+FORMATTER}) { my ($formatter, $source); if ($ENV{T2_FORMATTER}) { $source = "set by the 'T2_FORMATTER' environment variable"; if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { $formatter = $1 ? $2 : "Test2::Formatter::$2" } else { $formatter = ''; } } elsif (@{$self->{+FORMATTERS}}) { ($formatter) = @{$self->{+FORMATTERS}}; $source = "Most recently added"; } else { $formatter = 'Test2::Formatter::TAP'; $source = 'default formatter'; } unless (ref($formatter) || $formatter->can('write')) { my $file = pkg_to_file($formatter); my ($ok, $err) = try { require $file }; unless ($ok) { my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; my $border = '*' x length($line); die "\n\n $border\n $line\n $border\n\n$err"; } } $self->{+FORMATTER} = $formatter; } # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC # module is loaded. return if $self->{+IPC_DISABLED}; return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; # Turn on polling by default, people expect it. $self->enable_ipc_polling; unless (@{$self->{+IPC_DRIVERS}}) { my ($ok, $error) = try { require Test2::IPC::Driver::Files }; die $error unless $ok; push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; } for my $driver (@{$self->{+IPC_DRIVERS}}) { next unless $driver->can('is_viable') && $driver->is_viable; $self->{+IPC} = $driver->new or next; $self->ipc_enable_shm if $self->{+IPC}->use_shm; return; } die "IPC has been requested, but no viable drivers were found. Aborting...\n"; } sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } sub add_formatter { my $self = shift; my ($formatter) = @_; unshift @{$self->{+FORMATTERS}} => $formatter; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::Formatter'} = 1; carp "Formatter $formatter loaded too late to be used as the global formatter"; } sub add_context_acquire_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-acquire callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; } sub add_context_init_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-init callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; } sub add_context_release_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-release callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; } sub add_post_load_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Post-load callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+POST_LOAD_CALLBACKS}} => $code; $code->() if $self->{+LOADED}; } sub add_pre_subtest_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Pre-subtest callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code; } sub load { my $self = shift; unless ($self->{+LOADED}) { confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 # END blocks run in reverse order. This insures the END block is loaded # as late as possible. It will not solve all cases, but it helps. eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; $self->{+LOADED} = 1; $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; } return $self->{+LOADED}; } sub add_exit_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "End callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+EXIT_CALLBACKS}} => $code; } sub ipc_disable { my $self = shift; confess "Attempt to disable IPC after it has been initialized" if $self->{+IPC}; $self->{+IPC_DISABLED} = 1; } sub add_ipc_driver { my $self = shift; my ($driver) = @_; unshift @{$self->{+IPC_DRIVERS}} => $driver; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::IPC::Driver'} = 1; carp "IPC driver $driver loaded too late to be used as the global ipc driver"; } sub enable_ipc_polling { my $self = shift; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; $self->add_context_init_callback( # This is called every time a context is created, it needs to be fast. # $_[0] is a context object sub { return unless $self->{+IPC_POLLING}; return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID}; my $val; if(shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE})) { return if $val eq $self->{+IPC_SHM_LAST}; $self->{+IPC_SHM_LAST} = $val; } else { warn "SHM Read error: $!\n"; } $_[0]->{hub}->cull; } ) unless defined $self->ipc_polling; $self->set_ipc_polling(1); } sub ipc_enable_shm { my $self = shift; return 1 if defined $self->{+IPC_SHM_ID}; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; my ($ok, $err) = try { # SysV IPC can be available but not enabled. # # In some systems (*BSD) accessing the SysV IPC APIs without # them being enabled can cause a SIGSYS. We suppress the SIGSYS # and then get ENOSYS from the calls. local $SIG{SYS} = 'IGNORE' if CAN_SIGSYS; require IPC::SysV; my $ipc_key = IPC::SysV::IPC_PRIVATE(); my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64; my $shm_id = shmget($ipc_key, $shm_size, 0666) or die "Could not get shm: $!"; my $initial = 'a' x $shm_size; shmwrite($shm_id, $initial, 0, $shm_size) or die "Could not write to shm: $!"; my $val; shmread($shm_id, $val, 0, $shm_size) or die "Could not read from shm: $!"; die "Read SHM value does not match the initial value ('$val' vs '$initial')" unless $val eq $initial; $self->{+IPC_SHM_SIZE} = $shm_size; $self->{+IPC_SHM_ID} = $shm_id; $self->{+IPC_SHM_LAST} = $initial; }; return $ok; } sub ipc_free_shm { my $self = shift; my $id = delete $self->{+IPC_SHM_ID}; return unless defined $id; shmctl($id, IPC::SysV::IPC_RMID(), 0); } sub get_ipc_pending { my $self = shift; return -1 unless defined $self->{+IPC_SHM_ID}; my $val; shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1; return 0 if $val eq $self->{+IPC_SHM_LAST}; $self->{+IPC_SHM_LAST} = $val; return 1; } sub set_ipc_pending { my $self = shift; return undef unless defined $self->{+IPC_SHM_ID}; my ($val) = @_; confess "value is required for set_ipc_pending" unless $val; shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}); } sub disable_ipc_polling { my $self = shift; return unless defined $self->{+IPC_POLLING}; $self->{+IPC_POLLING} = 0; } sub _ipc_wait { my ($timeout) = @_; my $fail = 0; $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; my $ok = eval { if (CAN_FORK) { local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; alarm $timeout; while (1) { my $pid = CORE::wait(); my $err = $?; last if $pid == -1; next unless $err; $fail++; my $sig = $err & 127; my $exit = $err >> 8; warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n"; } alarm 0; } if (USE_THREADS) { my $start = time; while (1) { last unless threads->list(); die "Timeout waiting on child thread" if time - $start >= $timeout; sleep 1; for my $t (threads->list) { # threads older than 1.34 do not have this :-( next if $t->can('is_joinable') && !$t->is_joinable; $t->join; # In older threads we cannot check if a thread had an error unless # we control it and its return. my $err = $t->can('error') ? $t->error : undef; next unless $err; my $tid = $t->tid(); $fail++; chomp($err); warn "Thread $tid did not end cleanly: $err\n"; } } } 1; }; my $error = $@; return 0 if $ok && !$fail; warn $error unless $ok; return 255; } sub DESTROY { my $self = shift; return if $self->{+PRELOAD}; return unless defined($self->{+_PID}) && $self->{+_PID} == $$; return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid(); shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0) if defined $self->{+IPC_SHM_ID}; } sub set_exit { my $self = shift; return if $self->{+PRELOAD}; my $exit = $?; my $new_exit = $exit; if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { print STDERR <<" EOT"; ******************************************************************************** * * * Test::Builder -- Test2::API version mismatch detected * * * ******************************************************************************** Test2::API Version: $Test2::API::VERSION Test::Builder Version: $Test::Builder::VERSION This is not a supported configuration, you will have problems. EOT } for my $ctx (values %{$self->{+CONTEXTS}}) { next unless $ctx; next if $ctx->_aborted && ${$ctx->_aborted}; # Only worry about contexts in this PID my $trace = $ctx->trace || next; next unless $trace->pid && $trace->pid == $$; # Do not worry about contexts that have no hub my $hub = $ctx->hub || next; # Do not worry if the state came to a sudden end. next if $hub->bailed_out; next if defined $hub->skip_reason; # now we worry $trace->alert("context object was never released! This means a testing tool is behaving very badly"); $exit = 255; $new_exit = 255; } if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { $? = $exit; return; } my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { local $?; my %seen; for my $hub (reverse @hubs) { my $ipc = $hub->ipc or next; next if $seen{$ipc}++; $ipc->waiting(); } my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT}); $new_exit ||= $ipc_exit; } # None of this is necessary if we never got a root hub if(my $root = shift @hubs) { my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], detail => __PACKAGE__ . ' END Block finalization', ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); if (@hubs) { $ctx->diag("Test ended with extra hubs on the stack!"); $new_exit = 255; } unless ($root->no_ending) { local $?; $root->finalize($trace) unless $root->ended; $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; $new_exit ||= $root->failed; $new_exit ||= 255 unless $root->is_passing; } } $new_exit = 255 if $new_exit > 255; if ($new_exit && eval { require Test2::API::Breakage; 1 }) { my @warn = Test2::API::Breakage->report(); if (@warn) { print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; print STDERR "$_\n" for @warn; print STDERR "\n"; } } $? = $new_exit; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Instance - Object used by Test2::API under the hood =head1 DESCRIPTION This object encapsulates the global shared state tracked by L. A single global instance of this package is stored (and obscured) by the L package. There is no reason to directly use this package. This package is documented for completeness. This package can change, or go away completely at any time. Directly using, or monkeypatching this package is not supported in any way shape or form. =head1 SYNOPSIS use Test2::API::Instance; my $obj = Test2::API::Instance->new; =over 4 =item $pid = $obj->pid PID of this instance. =item $obj->tid Thread ID of this instance. =item $obj->reset() Reset the object to defaults. =item $obj->load() Set the internal state to loaded, and run and stored post-load callbacks. =item $bool = $obj->loaded Check if the state is set to loaded. =item $arrayref = $obj->post_load_callbacks Get the post-load callbacks. =item $obj->add_post_load_callback(sub { ... }) Add a post-load callback. If C has already been called then the callback will be immediately executed. If C has not been called then the callback will be stored and executed later when C is called. =item $hashref = $obj->contexts() Get a hashref of all active contexts keyed by hub id. =item $arrayref = $obj->context_acquire_callbacks Get all context acquire callbacks. =item $arrayref = $obj->context_init_callbacks Get all context init callbacks. =item $arrayref = $obj->context_release_callbacks Get all context release callbacks. =item $arrayref = $obj->pre_subtest_callbacks Get all pre-subtest callbacks. =item $obj->add_context_init_callback(sub { ... }) Add a context init callback. Subs are called every time a context is created. Subs get the newly created context as their only argument. =item $obj->add_context_release_callback(sub { ... }) Add a context release callback. Subs are called every time a context is released. Subs get the released context as their only argument. These callbacks should not call release on the context. =item $obj->add_pre_subtest_callback(sub { ... }) Add a pre-subtest callback. Subs are called every time a subtest is going to be run. Subs get the subtest name, coderef, and any arguments. =item $obj->set_exit() This is intended to be called in an C block. This will look at test state and set $?. This will also call any end callbacks, and wait on child processes/threads. =item $obj->ipc_enable_shm() Turn on SHM for IPC (if possible) =item $shm_id = $obj->ipc_shm_id() If SHM is enabled for IPC this will be the shm_id for it. =item $shm_size = $obj->ipc_shm_size() If SHM is enabled for IPC this will be the size of it. =item $shm_last_val = $obj->ipc_shm_last() If SHM is enabled for IPC this will return the last SHM value seen. =item $obj->set_ipc_pending($val) use the IPC SHM to tell other processes and threads there is a pending event. C<$val> should be a unique value no other thread/process will generate. B This will also make the current process see a pending event. It does not set C, this is important because doing so could hide a previous change. =item $pending = $obj->get_ipc_pending() This returns -1 if SHM is not enabled for IPC. This returns 0 if the SHM value matches the last known value, which means there are no pending events. This returns 1 if the SHM value has changed, which means there are probably pending events. When 1 is returned this will set C<< $obj->ipc_shm_last() >>. =item $timeout = $obj->ipc_timeout; =item $obj->set_ipc_timeout($timeout); How long to wait for child processes and threads before aborting. =item $drivers = $obj->ipc_drivers Get the list of IPC drivers. =item $obj->add_ipc_driver($DRIVER_CLASS) Add an IPC driver to the list. The most recently added IPC driver will become the global one during initialization. If a driver is added after initialization has occurred a warning will be generated: "IPC driver $driver loaded too late to be used as the global ipc driver" =item $bool = $obj->ipc_polling Check if polling is enabled. =item $obj->enable_ipc_polling Turn on polling. This will cull events from other processes and threads every time a context is created. =item $obj->disable_ipc_polling Turn off IPC polling. =item $bool = $obj->no_wait =item $bool = $obj->set_no_wait($bool) Get/Set no_wait. This option is used to turn off process/thread waiting at exit. =item $arrayref = $obj->exit_callbacks Get the exit callbacks. =item $obj->add_exit_callback(sub { ... }) Add an exit callback. This callback will be called by C. =item $bool = $obj->finalized Check if the object is finalized. Finalization happens when either C, C, or C are called on the object. Once finalization happens these fields are considered unchangeable (not enforced here, enforced by L). =item $ipc = $obj->ipc Get the one true IPC instance. =item $obj->ipc_disable Turn IPC off =item $bool = $obj->ipc_disabled Check if IPC is disabled =item $stack = $obj->stack Get the one true hub stack. =item $formatter = $obj->formatter Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> package. This could be any package that implements the C method. This can also be an instantiated object. =item $bool = $obj->formatter_set() Check if a formatter has been set. =item $obj->add_formatter($class) =item $obj->add_formatter($obj) Add a formatter. The most recently added formatter will become the global one during initialization. If a formatter is added after initialization has occurred a warning will be generated: "Formatter $formatter loaded too late to be used as the global formatter" =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/API/Context.pm0000644000175000017500000005655313243466361020225 0ustar exodistexodistpackage Test2::API::Context; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/confess croak/; use Scalar::Util qw/weaken blessed/; use Test2::Util qw/get_tid try pkg_to_file get_tid/; use Test2::EventFacet::Trace(); use Test2::API(); # Preload some key event types my %LOADED = ( map { my $pkg = "Test2::Event::$_"; my $file = "Test2/Event/$_.pm"; require $file unless $INC{$file}; ( $pkg => $pkg, $_ => $pkg ) } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail/ ); use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ stack hub trace _on_release _depth _is_canon _is_spawn _aborted errno eval_error child_error thrown }; # Private, not package vars # It is safe to cache these. my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); my $CONTEXTS = Test2::API::_contexts_ref(); sub init { my $self = shift; confess "The 'trace' attribute is required" unless $self->{+TRACE}; confess "The 'hub' attribute is required" unless $self->{+HUB}; $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; } sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } sub restore_error_vars { my $self = shift; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; } sub DESTROY { return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; my ($self) = @_; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; # Do not show the warning if it looks like an exception has been thrown, or # if the context is not local to this process or thread. { # Sometimes $@ is uninitialized, not a problem in this case so do not # show the warning about using eq. no warnings 'uninitialized'; if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; warn <<" EOT"; A context appears to have been destroyed without first calling release(). Based on \$@ it does not look like an exception was thrown (this is not always a reliable test) This is a problem because the global error variables (\$!, \$@, and \$?) will not be restored. In addition some release callbacks will not work properly from inside a DESTROY method. Here are the context creation details, just in case a tool forgot to call release(): File: $frame->[1] Line: $frame->[2] Tool: $frame->[3] Cleaning up the CONTEXT stack... EOT } } return if $self->{+_IS_SPAWN}; # Remove the key itself to avoid a slow memory leak delete $CONTEXTS->{$hid}; $self->{+_IS_CANON} = undef; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; } # release exists to implement behaviors like die-on-fail. In die-on-fail you # want to die after a failure, but only after diagnostics have been reported. # The ideal time for the die to happen is when the context is released. # Unfortunately die does not work in a DESTROY block. sub release { my ($self) = @_; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef if $self->{+_IS_SPAWN}; croak "release() should not be called on context that is neither canon nor a child" unless $self->{+_IS_CANON}; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; croak "context thinks it is canon, but it is not" unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; # Remove the key itself to avoid a slow memory leak $self->{+_IS_CANON} = undef; delete $CONTEXTS->{$hid}; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; # Do this last so that nothing else changes them. # If one of the hooks dies then these do not get restored, this is # intentional ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; return; } sub do_in_context { my $self = shift; my ($sub, @args) = @_; # We need to update the pid/tid and error vars. my $clone = $self->snapshot; @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); my $hub = $clone->{+HUB}; my $hid = $hub->hid; my $old = $CONTEXTS->{$hid}; $clone->{+_IS_CANON} = 1; $CONTEXTS->{$hid} = $clone; weaken($CONTEXTS->{$hid}); my ($ok, $err) = &try($sub, @args); my ($rok, $rerr) = try { $clone->release }; delete $clone->{+_IS_CANON}; if ($old) { $CONTEXTS->{$hid} = $old; weaken($CONTEXTS->{$hid}); } else { delete $CONTEXTS->{$hid}; } die $err unless $ok; die $rerr unless $rok; } sub done_testing { my $self = shift; $self->hub->finalize($self->trace, 1); return; } sub throw { my ($self, $msg) = @_; $self->{+THROWN} = 1; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; $self->trace->throw($msg); } sub alert { my ($self, $msg) = @_; $self->trace->alert($msg); } sub send_event_and_release { my $self = shift; my $out = $self->send_event(@_); $self->release; return $out; } sub send_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); my $e; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $e = $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } if ($self->{+_ABORTED}) { my $f = $e->facet_data; ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); } $self->{+HUB}->send($e); } sub build_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); local $Carp::CarpLevel = $Carp::CarpLevel + 1; $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } sub pass { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); return $e; } sub pass_and_release { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); $self->release; return 1; } sub fail { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; $self->{+HUB}->send($e); return $e; } sub fail_and_release { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; $self->{+HUB}->send($e); $self->release; return 0; } sub ok { my $self = shift; my ($pass, $name, $on_fail) = @_; my $hub = $self->{+HUB}; my $e = bless { trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), pass => $pass, name => $name, }, 'Test2::Event::Ok'; $e->init; $hub->send($e); return $e if $pass; $self->failure_diag($e); if ($on_fail && @$on_fail) { $self->diag($_) for @$on_fail; } return $e; } sub failure_diag { my $self = shift; my ($e) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $e->name; my $trace = $e->trace; my $debug = $trace ? $trace->debug : "[No trace info available]"; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[Failed test '$name'\n$debug.\n] : qq[Failed test $debug.\n]; $self->diag($msg); } sub skip { my $self = shift; my ($name, $reason, @extra) = @_; $self->send_event( 'Skip', name => $name, reason => $reason, pass => 1, @extra, ); } sub note { my $self = shift; my ($message) = @_; $self->send_event('Note', message => $message); } sub diag { my $self = shift; my ($message) = @_; my $hub = $self->{+HUB}; $self->send_event( 'Diag', message => $message, ); } sub plan { my ($self, $max, $directive, $reason) = @_; $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); } sub bail { my ($self, $reason) = @_; $self->send_event('Bail', reason => $reason); } sub _parse_event { my $self = shift; my $event = shift; my $pkg; if ($event =~ m/^\+(.*)/) { $pkg = $1; } else { $pkg = "Test2::Event::$event"; } unless ($LOADED{$pkg}) { my $file = pkg_to_file($pkg); my ($ok, $err) = try { require $file }; $self->throw("Could not load event module '$pkg': $err") unless $ok; $LOADED{$pkg} = $pkg; } confess "'$pkg' is not a subclass of 'Test2::Event'" unless $pkg->isa('Test2::Event'); $LOADED{$event} = $pkg; return $pkg; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Context - Object to represent a testing context. =head1 DESCRIPTION The context object is the primary interface for authors of testing tools written with L. The context object represents the context in which a test takes place (File and Line Number), and provides a quick way to generate events from that context. The context object also takes care of sending events to the correct L instance. =head1 SYNOPSIS In general you will not be creating contexts directly. To obtain a context you should always use C which is exported by the L module. use Test2::API qw/context/; sub my_ok { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; # You MUST do this! return $bool; } Context objects make it easy to wrap other tools that also use context. Once you grab a context, any tool you call before releasing your context will inherit it: sub wrapper { my ($bool, $name) = @_; my $ctx = context(); $ctx->diag("wrapping my_ok"); my $out = my_ok($bool, $name); $ctx->release; # You MUST do this! return $out; } =head1 CRITICAL DETAILS =over 4 =item you MUST always use the context() sub from Test2::API Creating your own context via C<< Test2::API::Context->new() >> will almost never produce a desirable result. Use C which is exported by L. There are a handful of cases where a tool author may want to create a new context by hand, which is why the C method exists. Unless you really know what you are doing you should avoid this. =item You MUST always release the context when done with it Releasing the context tells the system you are done with it. This gives it a chance to run any necessary callbacks or cleanup tasks. If you forget to release the context it will try to detect the problem and warn you about it. =item You MUST NOT pass context objects around When you obtain a context object it is made specifically for your tool and any tools nested within. If you pass a context around you run the risk of polluting other tools with incorrect context information. If you are certain that you want a different tool to use the same context you may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. =item You MUST NOT store or cache a context for later As long as a context exists for a given hub, all tools that try to get a context will get the existing instance. If you try to store the context you will pollute other tools with incorrect context information. If you are certain that you want to save the context for later, you can use a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. C has some mechanisms to protect you if you do cause a context to persist beyond the scope in which it was obtained. In practice you should not rely on these protections, and they are fairly noisy with warnings. =item You SHOULD obtain your context as soon as possible in a given tool You never know what tools you call from within your own tool will need a context. Obtaining the context early ensures that nested tools can find the context you want them to find. =back =head1 METHODS =over 4 =item $ctx->done_testing; Note that testing is finished. If no plan has been set this will generate a Plan event. =item $clone = $ctx->snapshot() This will return a shallow clone of the context. The shallow clone is safe to store for later. =item $ctx->release() This will release the context. This runs cleanup tasks, and several important hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the context was created. B If a context is acquired more than once an internal refcount is kept. C decrements the ref count, none of the other actions of C will occur unless the refcount hits 0. This means only the last call to C will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. =item $ctx->throw($message) This will throw an exception reporting to the file and line number of the context. This will also release the context for you. =item $ctx->alert($message) This will issue a warning from the file and line number of the context. =item $stack = $ctx->stack() This will return the L instance the context used to find the current hub. =item $hub = $ctx->hub() This will return the L instance the context recognizes as the current one to which all events should be sent. =item $dbg = $ctx->trace() This will return the L instance used by the context. =item $ctx->do_in_context(\&code, @args); Sometimes you have a context that is not current, and you want things to use it as the current one. In these cases you can call C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and anything inside of it that looks for a context will find the one on which the method was called. This B affect context on other hubs, only the hub used by the context will be affected. my $ctx = ...; $ctx->do_in_context(sub { my $ctx = context(); # returns the $ctx the sub is called on }); B The context will actually be cloned, the clone will be used instead of the original. This allows the thread id, process id, and error variables to be correct without modifying the original context. =item $ctx->restore_error_vars() This will set C<$!>, C<$?>, and C<$@> to what they were when the context was created. There is no localization or anything done here, calling this method will actually set these vars. =item $! = $ctx->errno() The (numeric) value of C<$!> when the context was created. =item $? = $ctx->child_error() The value of C<$?> when the context was created. =item $@ = $ctx->eval_error() The value of C<$@> when the context was created. =back =head2 EVENT PRODUCTION METHODS =over 4 =item $event = $ctx->pass() =item $event = $ctx->pass($name) This will send and return an L event. You may optionally provide a C<$name> for the assertion. The L is a specially crafted and optimized event, using this will help the performance of passing tests. =item $true = $ctx->pass_and_release() =item $true = $ctx->pass_and_release($name) This is a combination of C and C. You can use this if you do not plan to do anything with the context after sending the event. This helps write more clear and compact code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; ... Handle a failure ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); if ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a failure ... } =item my $event = $ctx->fail() =item my $event = $ctx->fail($name) =item my $event = $ctx->fail($name, @diagnostics) This lets you send an L event. You may optionally provide a C<$name> and C<@diagnostics> messages. =item my $false = $ctx->fail_and_release() =item my $false = $ctx->fail_and_release($name) =item my $false = $ctx->fail_and_release($name, @diagnostics) This is a combination of C and C. This can be used to write clearer and shorter code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->fail_and_release($name) unless $bool; ... Handle a success ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); unless ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a success ... } =item $event = $ctx->ok($bool, $name) =item $event = $ctx->ok($bool, $name, \@on_fail) B Use of this method is discouraged in favor of C and C which produce L and L events. These newer event types are faster and less crufty. This will create an L object for you. If C<$bool> is false then an L event will be sent as well with details about the failure. If you do not want automatic diagnostics you should use the C method directly. The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in the event of a test failure. =item $event = $ctx->note($message) Send an L. This event prints a message to STDOUT. =item $event = $ctx->diag($message) Send an L. This event prints a message to STDERR. =item $event = $ctx->plan($max) =item $event = $ctx->plan(0, 'SKIP', $reason) This can be used to send an L event. This event usually takes either a number of tests you expect to run. Optionally you can set the expected count to 0 and give the 'SKIP' directive with a reason to cause all tests to be skipped. =item $event = $ctx->skip($name, $reason); Send an L event. =item $event = $ctx->bail($reason) This sends an L event. This event will completely terminate all testing. =item $event = $ctx->send_event($Type, %parameters) This lets you build and send an event of any type. The C<$Type> argument should be the event package name with C left off, or a fully qualified package name prefixed with a '+'. The event is returned after it is sent. my $event = $ctx->send_event('Ok', ...); or my $event = $ctx->send_event('+Test2::Event::Ok', ...); =item $event = $ctx->build_event($Type, %parameters) This is the same as C, except it builds and returns the event without sending it. =item $event = $ctx->send_event_and_release($Type, %parameters) This is a combination of C and C. sub shorthand { my $ctx = context(); return $ctx->send_event_and_release(Pass => { name => 'foo' }); } sub longform { my $ctx = context(); my $event = $ctx->send_event(Pass => { name => 'foo' }); $ctx->release; return $event; } =back =head1 HOOKS There are 2 types of hooks, init hooks, and release hooks. As the names suggest, these hooks are triggered when contexts are created or released. =head2 INIT HOOKS These are called whenever a context is initialized. That means when a new instance is created. These hooks are B called every time something requests a context, just when a new one is created. =head3 GLOBAL This is how you add a global init callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_init(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add an init callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_init(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you specify an init hook that will only run if your call to C generates a new context. The callback will be ignored if C is returning an existing context. my $ctx = context(on_init => sub { my $ctx = shift; ... }); =head2 RELEASE HOOKS These are called whenever a context is released. That means when the last reference to the instance is about to be destroyed. These hooks are B called every time C<< $ctx->release >> is called. =head3 GLOBAL This is how you add a global release callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_release(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add a release callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_release(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you add release callbacks directly to a context. The callback will B be added to the context that gets returned, it does not matter if a new one is generated, or if an existing one is returned. my $ctx = context(on_release => sub { my $ctx = shift; ... }); =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/API/Stack.pm0000644000175000017500000001125113243466361017630 0ustar exodistexodistpackage Test2::API::Stack; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Hub(); use Carp qw/confess/; sub new { my $class = shift; return bless [], $class; } sub new_hub { my $self = shift; my %params = @_; my $class = delete $params{class} || 'Test2::Hub'; my $hub = $class->new(%params); if (@$self) { $hub->inherit($self->[-1], %params); } else { require Test2::API; $hub->format(Test2::API::test2_formatter()->new_root) unless $hub->format || exists($params{formatter}); my $ipc = Test2::API::test2_ipc(); if ($ipc && !$hub->ipc && !exists($params{ipc})) { $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } } push @$self => $hub; $hub; } sub top { my $self = shift; return $self->new_hub unless @$self; return $self->[-1]; } sub peek { my $self = shift; return @$self ? $self->[-1] : undef; } sub cull { my $self = shift; $_->cull for reverse @$self; } sub all { my $self = shift; return @$self; } sub clear { my $self = shift; @$self = (); } # Do these last without keywords in order to prevent them from getting used # when we want the real push/pop. { no warnings 'once'; *push = sub { my $self = shift; my ($hub) = @_; $hub->inherit($self->[-1]) if @$self; push @$self => $hub; }; *pop = sub { my $self = shift; my ($hub) = @_; confess "No hubs on the stack" unless @$self; confess "You cannot pop the root hub" if 1 == @$self; confess "Hub stack mismatch, attempted to pop incorrect hub" unless $self->[-1] == $hub; pop @$self; }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Stack - Object to manage a stack of L instances. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwards incompatible ways, but the underlying implementation details might. B =head1 DESCRIPTION This module is used to represent and manage a stack of L objects. Hubs are usually in a stack so that you can push a new hub into place that can intercept and handle events differently than the primary hub. =head1 SYNOPSIS my $stack = Test2::API::Stack->new; my $hub = $stack->top; =head1 METHODS =over 4 =item $stack = Test2::API::Stack->new() This will create a new empty stack instance. All arguments are ignored. =item $hub = $stack->new_hub() =item $hub = $stack->new_hub(%params) =item $hub = $stack->new_hub(%params, class => $class) This will generate a new hub and push it to the top of the stack. Optionally you can provide arguments that will be passed into the constructor for the L object. If you specify the C<< 'class' => $class >> argument, the new hub will be an instance of the specified class. Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the formatter and IPC instance will be inherited from the current top hub. You can set the parameters to C to avoid having a formatter or IPC instance. If there is no top hub, and you do not ask to leave IPC and formatter undef, then a new formatter will be created, and the IPC instance from L will be used. =item $hub = $stack->top() This will return the top hub from the stack. If there is no top hub yet this will create it. =item $hub = $stack->peek() This will return the top hub from the stack. If there is no top hub yet this will return undef. =item $stack->cull This will call C<< $hub->cull >> on all hubs in the stack. =item @hubs = $stack->all This will return all the hubs in the stack as a list. =item $stack->clear This will completely remove all hubs from the stack. Normally you do not want to do this, but there are a few valid reasons for it. =item $stack->push($hub) This will push the new hub onto the stack. =item $stack->pop($hub) This will pop a hub from the stack, if the hub at the top of the stack does not match the hub you expect (passed in as an argument) it will throw an exception. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Formatter.pm0000644000175000017500000000654113243466361020123 0ustar exodistexodistpackage Test2::Formatter; use strict; use warnings; our $VERSION = '1.302125'; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; require Test2::API; Test2::API::test2_formatter_add($class); } sub new_root { my $class = shift; return $class->new(@_); } sub hide_buffered { 1 } sub terminate { } sub finalize { } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter - Namespace for formatters. =head1 DESCRIPTION This is the namespace for formatters. This is an empty package. =head1 CREATING FORMATTERS A formatter is any package or object with a C method. package Test2::Formatter::Foo; use strict; use warnings; sub write { my $self_or_class = shift; my ($event, $assert_num) = @_; ... } sub hide_buffered { 1 } sub terminate { } sub finalize { } sub new_root { my $class = shift; ... $class->new(@_); } 1; The C method is a method, so it either gets a class or instance. The two arguments are the C<$event> object it should record, and the C<$assert_num> which is the number of the current assertion (ok), or the last assertion if this event is not itself an assertion. The assertion number may be any integer 0 or greater, and may be undefined in some cases. The C method must return a boolean. This is used to tell buffered subtests whether or not to send it events as they are being buffered. See L for more information. The C and C methods are optional methods called that you can implement if the format you're generating needs to handle these cases, for example if you are generating XML and need close open tags. The C method is called when an event's C method returns true, for example when a L has a C<'skip_all'> plan, or when a L event is sent. The C method is passed a single argument, the L object which triggered the terminate. The C method is always the last thing called on the formatter, I<< except when C is called for a Bail event >>. It is passed the following arguments: The C method is called when C Initializes the root hub for the first time. Most formatters will simply have this call C<< $class->new >>, which is the default behavior. Some formatters however may want to take extra action during construction of the root formatter, this is where they can do that. =over 4 =item * The number of tests that were planned =item * The number of tests actually seen =item * The number of tests which failed =item * A boolean indicating whether or not the test suite passed =item * A boolean indicating whether or not this call is for a subtest =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/0000755000175000017500000000000013243466361016675 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Event/TAP/0000755000175000017500000000000013243466361017321 5ustar exodistexodistTest-Simple-1.302125/lib/Test2/Event/TAP/Version.pm0000644000175000017500000000315413243466361021307 0ustar exodistexodistpackage Test2::Event::TAP::Version; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/version/; sub init { my $self = shift; defined $self->{+VERSION} or croak "'version' is a required attribute"; } sub summary { 'TAP version ' . $_[0]->{+VERSION} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::TAP::Version - Event for TAP version. =head1 DESCRIPTION This event is used if a TAP formatter wishes to set a version. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('TAP::Version', version => 42); =head1 METHODS Inherits from L. Also defines: =over 4 =item $version = $e->version The TAP version being parsed. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Exception.pm0000644000175000017500000000336513243466361021200 0ustar exodistexodistpackage Test2::Event::Exception; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{error}; sub init { my $self = shift; $self->{+ERROR} = "$self->{+ERROR}"; } sub causes_fail { 1 } sub summary { my $self = shift; chomp(my $msg = "Exception: " . $self->{+ERROR}); return $msg; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{errors} = [ { tag => 'ERROR', fail => 1, details => $self->{+ERROR}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Exception - Exception event =head1 DESCRIPTION An exception event will display to STDERR, and will prevent the overall test file from passing. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Exception; my $ctx = context(); my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->error The reason for the exception. =back =head1 CAVEATS Be aware that all exceptions are stringified during construction. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Encoding.pm0000644000175000017500000000335113243466361020763 0ustar exodistexodistpackage Test2::Event::Encoding; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/encoding/; sub init { my $self = shift; defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; } sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{encoding} = $self->{+ENCODING}; $out->{about}->{details} = $self->summary; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Encoding - Set the encoding for the output stream =head1 DESCRIPTION The encoding event is generated when a test file wants to specify the encoding to be used when formatting its output. This event is intended to be produced by formatter classes and used for interpreting test names, message contents, etc. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $encoding = $e->encoding The encoding being specified. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Subtest.pm0000644000175000017500000000616013243466361020667 0ustar exodistexodistpackage Test2::Event::Subtest; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id}; sub init { my $self = shift; $self->SUPER::init(); $self->{+SUBEVENTS} ||= []; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } } { no warnings 'redefine'; sub set_subevents { my $self = shift; my @subevents = @_; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; } $self->{+SUBEVENTS} = \@subevents; } sub set_effective_pass { my $self = shift; my ($pass) = @_; if ($pass) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } elsif ($self->{+EFFECTIVE_PASS} && !$pass) { for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; } } $self->{+EFFECTIVE_PASS} = $pass; } } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Subtest"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)"; } return $name; } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); $out->{parent} = { hid => $self->subtest_id, children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], buffered => $self->{+BUFFERED}, }; return $out; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; for my $e (@{$self->{+SUBEVENTS}}) { $e->add_amnesty($am->clone(inherited => 1)); } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Subtest - Event for subtest types =head1 DESCRIPTION This class represents a subtest. This class is a subclass of L. =head1 ACCESSORS This class inherits from L. =over 4 =item $arrayref = $e->subevents Returns the arrayref containing all the events from the subtest =item $bool = $e->buffered True if the subtest is buffered, that is all subevents render at once. If this is false it means all subevents render as they are produced. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Waiting.pm0000644000175000017500000000232613243466361020640 0ustar exodistexodistpackage Test2::Event::Waiting; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; sub global { 1 }; sub summary { "IPC is waiting for children to finish..." } sub facet_data { my $self = shift; my $out = $self->common_facet_data; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Waiting - Tell all procs/threads it is time to be done =head1 DESCRIPTION This event has no data of its own. This event is sent out by the IPC system when the main process/thread is ready to end. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Generic.pm0000644000175000017500000001342513243466361020614 0ustar exodistexodistpackage Test2::Event::Generic; use strict; use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; my @FIELDS = qw{ causes_fail increments_count diagnostics no_display callback terminate global sets_plan summary facet_data }; my %DEFAULTS = ( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, ); sub init { my $self = shift; for my $field (@FIELDS) { my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; next unless defined $val; my $set = "set_$field"; $self->$set($val); } } for my $field (@FIELDS) { no strict 'refs'; *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } unless exists &{$field}; *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } unless exists &{"set_$field"}; } sub can { my $self = shift; my ($name) = @_; return $self->SUPER::can($name) unless $name eq 'callback'; return $self->{callback} || \&Test2::Event::callback; } sub facet_data { my $self = shift; return $self->{facet_data} || $self->SUPER::facet_data(); } sub summary { my $self = shift; return $self->{summary} if defined $self->{summary}; $self->SUPER::summary(); } sub sets_plan { my $self = shift; return unless $self->{sets_plan}; return @{$self->{sets_plan}}; } sub callback { my $self = shift; my $cb = $self->{callback} || return; $self->$cb(@_); } sub set_global { my $self = shift; my ($bool) = @_; if(!defined $bool) { delete $self->{global}; return undef; } $self->{global} = $bool; } sub set_callback { my $self = shift; my ($cb) = @_; if(!defined $cb) { delete $self->{callback}; return undef; } croak "callback must be a code reference" unless ref($cb) && reftype($cb) eq 'CODE'; $self->{callback} = $cb; } sub set_terminate { my $self = shift; my ($exit) = @_; if(!defined $exit) { delete $self->{terminate}; return undef; } croak "terminate must be a positive integer" unless $exit =~ m/^\d+$/; $self->{terminate} = $exit; } sub set_sets_plan { my $self = shift; my ($plan) = @_; if(!defined $plan) { delete $self->{sets_plan}; return undef; } croak "'sets_plan' must be an array reference" unless ref($plan) && reftype($plan) eq 'ARRAY'; $self->{sets_plan} = $plan; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Generic - Generic event type. =head1 DESCRIPTION This is a generic event that lets you customize all fields in the event API. This is useful if you have need for a custom event that does not make sense as a published reusable event subclass. =head1 SYNOPSIS use Test2::API qw/context/; sub send_custom_fail { my $ctx = shift; $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); $ctx->release; } send_custom_fail(); =head1 METHODS =over 4 =item $e->facet_data($data) =item $data = $e->facet_data Get or set the facet data (see L). If no facet_data is set then C<< Test2::Event->facet_data >> will be called to produce facets from the other data. =item $e->callback($hub) Call the custom callback if one is set, otherwise this does nothing. =item $e->set_callback(sub { ... }) Set the custom callback. The custom callback must be a coderef. The first argument to your callback will be the event itself, the second will be the L that is using the callback. =item $bool = $e->causes_fail =item $e->set_causes_fail($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool = $e->diagnostics =item $e->set_diagnostics($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool_or_undef = $e->global =item @bool_or_empty = $e->global =item $e->set_global($bool_or_undef) Get/Set the C attribute. This defaults to an empty list which is undef in scalar context. =item $bool = $e->increments_count =item $e->set_increments_count($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool = $e->no_display =item $e->set_no_display($bool) Get/Set the C attribute. This defaults to C<0>. =item @plan = $e->sets_plan Get the plan if this event sets one. The plan is a list of up to 3 items: C<($count, $directive, $reason)>. C<$count> must be defined, the others may be undef, or may not exist at all. =item $e->set_sets_plan(\@plan) Set the plan. You must pass in an arrayref with up to 3 elements. =item $summary = $e->summary =item $e->set_summary($summary_or_undef) Get/Set the summary. This will default to the event package C<'Test2::Event::Generic'>. You can set it to any value. Setting this to C will reset it to the default. =item $int_or_undef = $e->terminate =item @int_or_empty = $e->terminate =item $e->set_terminate($int_or_undef) This will get/set the C attribute. This defaults to undef in scalar context, or an empty list in list context. Setting this to undef will clear it completely. This must be set to a positive integer (0 or larger). =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Note.pm0000644000175000017500000000261113243466361020140 0ustar exodistexodistpackage Test2::Event::Note; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'NOTE', debug => 0, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Note - Note event type =head1 DESCRIPTION Notes, typically rendered to STDOUT. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Note; my $ctx = context(); my $event = $ctx->Note($message); =head1 ACCESSORS =over 4 =item $note->message The message for the note. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Skip.pm0000644000175000017500000000373213243466361020146 0ustar exodistexodistpackage Test2::Event::Skip; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{reason}; sub init { my $self = shift; $self->SUPER::init; $self->{+EFFECTIVE_PASS} = 1; } sub causes_fail { 0 } sub summary { my $self = shift; my $out = $self->SUPER::summary(@_); if (my $reason = $self->reason) { $out .= " (SKIP: $reason)"; } else { $out .= " (SKIP)"; } return $out; } sub extra_amnesty { my $self = shift; my @out; push @out => { tag => 'TODO', details => $self->{+TODO}, } if defined $self->{+TODO}; push @out => { tag => 'skip', details => $self->{+REASON}, inherited => 0, }; return @out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Skip - Skip event type =head1 DESCRIPTION Skip events bump test counts just like L events, but they can never fail. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Skip; my $ctx = context(); my $event = $ctx->skip($name, $reason); or: my $ctx = context(); my $event = $ctx->send_event( 'Skip', name => $name, reason => $reason, ); =head1 ACCESSORS =over 4 =item $reason = $e->reason The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Pass.pm0000644000175000017500000000361613243466361020147 0ustar exodistexodistpackage Test2::Event::Pass; use strict; use warnings; our $VERSION = '1.302125'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############## # Old API sub summary { "pass" } sub increments_count { 1 } sub causes_fail { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } ############## # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'pass'; $out->{assert} = {pass => 1, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Pass - Event for a simple passing assertion =head1 DESCRIPTION This is an optimal representation of a passing assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub pass { my ($name) = @_; my $ctx = context(); $ctx->pass($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Plan.pm0000644000175000017500000000647413243466361020140 0ustar exodistexodistpackage Test2::Event::Plan; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{max directive reason}; use Carp qw/confess/; my %ALLOWED = ( 'SKIP' => 1, 'NO PLAN' => 1, ); sub init { if ($_[0]->{+DIRECTIVE}) { $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" unless $ALLOWED{$_[0]->{+DIRECTIVE}}; } else { confess "Cannot have a reason without a directive!" if defined $_[0]->{+REASON}; confess "No number of tests specified" unless defined $_[0]->{+MAX}; confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" unless $_[0]->{+MAX} =~ m/^\d+$/; $_[0]->{+DIRECTIVE} = ''; } } sub sets_plan { my $self = shift; return ( $self->{+MAX}, $self->{+DIRECTIVE}, $self->{+REASON}, ); } sub terminate { my $self = shift; # On skip_all we want to terminate the hub return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; return undef; } sub summary { my $self = shift; my $max = $self->{+MAX}; my $directive = $self->{+DIRECTIVE}; my $reason = $self->{+REASON}; return "Plan is $max assertions" if $max || !$directive; return "Plan is '$directive', $reason" if $reason; return "Plan is '$directive'"; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef unless defined $out->{control}->{terminate}; $out->{plan} = {count => $self->{+MAX}}; $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; if (my $dir = $self->{+DIRECTIVE}) { $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Plan - The event of a plan =head1 DESCRIPTION Plan events are fired off whenever a plan is declared, done testing is called, or a subtext completes. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Plan; my $ctx = context(); # Plan for 10 tests to run my $event = $ctx->plan(10); # Plan to skip all tests (will exit 0) $ctx->plan(0, skip_all => "These tests need to be skipped"); =head1 ACCESSORS =over 4 =item $num = $plan->max Get the number of expected tests =item $dir = $plan->directive Get the directive (such as TODO, skip_all, or no_plan). =item $reason = $plan->reason Get the reason for the directive. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Fail.pm0000644000175000017500000000374213243466361020114 0ustar exodistexodistpackage Test2::Event::Fail; use strict; use warnings; our $VERSION = '1.302125'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############# # Old API sub summary { "fail" } sub increments_count { 1 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } sub causes_fail { my $self = shift; return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; return 1; } ############# # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'fail'; $out->{assert} = {pass => 0, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Fail - Event for a simple failed assertion =head1 DESCRIPTION This is an optimal representation of a failed assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub fail { my ($name) = @_; my $ctx = context(); $ctx->fail($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Bail.pm0000644000175000017500000000324013243466361020101 0ustar exodistexodistpackage Test2::Event::Bail; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{reason buffered}; # Make sure the tests terminate sub terminate { 255 }; sub global { 1 }; sub causes_fail { 1 } sub summary { my $self = shift; return "Bail out! " . $self->{+REASON} if $self->{+REASON}; return "Bail out!"; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control} = { global => 1, halt => 1, details => $self->{+REASON}, terminate => 255, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Bail - Bailout! =head1 DESCRIPTION The bailout event is generated when things go horribly wrong and you need to halt all testing in the current file. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Bail; my $ctx = context(); my $event = $ctx->bail('Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->reason The reason for the bailout. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Diag.pm0000644000175000017500000000265713243466361020111 0ustar exodistexodistpackage Test2::Event::Diag; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Diag - Diag event type =head1 DESCRIPTION Diagnostics messages, typically rendered to STDERR. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Diag; my $ctx = context(); my $event = $ctx->diag($message); =head1 ACCESSORS =over 4 =item $diag->message The message for the diag. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event/Ok.pm0000644000175000017500000000552313243466361017611 0ustar exodistexodistpackage Test2::Event::Ok; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{ pass effective_pass name todo }; sub init { my $self = shift; # Do not store objects here, only true or false $self->{+PASS} = $self->{+PASS} ? 1 : 0; $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); } { no warnings 'redefine'; sub set_todo { my $self = shift; my ($todo) = @_; $self->{+TODO} = $todo; $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; } } sub increments_count { 1 }; sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Assertion"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)" } return $name; } sub extra_amnesty { my $self = shift; return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); return { tag => 'TODO', details => $self->{+TODO}, }; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->{+PASS}, details => $self->{+NAME}, }; if (my @exra_amnesty = $self->extra_amnesty) { unshift @{$out->{amnesty}} => @exra_amnesty; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Ok - Ok event type =head1 DESCRIPTION Ok events are generated whenever you run a test that produces a result. Examples are C, and C. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Ok; my $ctx = context(); my $event = $ctx->ok($bool, $name, \@diag); or: my $ctx = context(); my $event = $ctx->send_event( 'Ok', pass => $bool, name => $name, ); =head1 ACCESSORS =over 4 =item $rb = $e->pass The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =item $name = $e->name Name of the test. =item $b = $e->effective_pass This is the true/false value of the test after TODO and similar modifiers are taken into account. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Event.pm0000644000175000017500000004141013243466361017233 0ustar exodistexodistpackage Test2::Event; use strict; use warnings; our $VERSION = '1.302125'; use Test2::Util::HashBase qw/trace -amnesty/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util qw(pkg_to_file); use Test2::EventFacet::About(); use Test2::EventFacet::Amnesty(); use Test2::EventFacet::Assert(); use Test2::EventFacet::Control(); use Test2::EventFacet::Error(); use Test2::EventFacet::Info(); use Test2::EventFacet::Meta(); use Test2::EventFacet::Parent(); use Test2::EventFacet::Plan(); use Test2::EventFacet::Trace(); my @FACET_TYPES = qw{ Test2::EventFacet::About Test2::EventFacet::Amnesty Test2::EventFacet::Assert Test2::EventFacet::Control Test2::EventFacet::Error Test2::EventFacet::Info Test2::EventFacet::Meta Test2::EventFacet::Parent Test2::EventFacet::Plan Test2::EventFacet::Trace }; sub FACET_TYPES() { @FACET_TYPES } # Legacy tools will expect this to be loaded now require Test2::Util::Trace; sub causes_fail { 0 } sub increments_count { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub callback { } sub terminate { () } sub global { () } sub sets_plan { () } sub summary { ref($_[0]) } sub related { my $self = shift; my ($event) = @_; my $tracea = $self->trace or return undef; my $traceb = $event->trace or return undef; my $siga = $tracea->signature or return undef; my $sigb = $traceb->signature or return undef; return 1 if $siga eq $sigb; return 0; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; } } sub common_facet_data { my $self = shift; my %out; $out{about} = {package => ref($self) || undef}; if (my $trace = $self->trace) { $out{trace} = { %$trace }; } $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] if $self->{+AMNESTY}; my $key = Test2::Util::ExternalMeta::META_KEY(); if (my $hash = $self->{$key}) { $out{meta} = {%$hash}; } return \%out; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary || undef; $out->{about}->{no_display} = $self->no_display || undef; # Might be undef, we want to preserve that my $terminate = $self->terminate; $out->{control} = { global => $self->global || 0, terminate => $terminate, has_callback => $self->can('callback') == \&callback ? 0 : 1, }; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->causes_fail ? 0 : 1, details => $self->summary, } if $self->increments_count; $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; if (my @plan = $self->sets_plan) { $out->{plan} = {}; $out->{plan}->{count} = $plan[0] if defined $plan[0]; $out->{plan}->{details} = $plan[2] if defined $plan[2]; if ($plan[1]) { $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; } $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; } if ($self->causes_fail && !$out->{assert}) { $out->{errors} = [ { tag => 'FAIL', fail => 1, details => $self->summary, } ]; } my %IGNORE = (trace => 1, about => 1, control => 1); my $do_info = !grep { !$IGNORE{$_} } keys %$out; if ($do_info && !$self->no_display && $self->diagnostics) { $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->summary, } ]; } return $out; } sub facets { my $self = shift; my $data = $self->facet_data; my %out; for my $type (FACET_TYPES()) { my $key = $type->facet_key; next unless $data->{$key}; if ($type->is_list) { $out{$key} = [map { $type->new($_) } @{$data->{$key}}]; } else { $out{$key} = $type->new($data->{$key}); } } return \%out; } sub nested { Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") if $ENV{AUTHOR_TESTING}; $_[0]->{+TRACE}->{nested}; } sub in_subtest { Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") if $ENV{AUTHOR_TESTING}; # Return undef if we are not nested, Legacy did not return the hid if nestign was 0. return undef unless $_[0]->{+TRACE}->{nested}; $_[0]->{+TRACE}->{hid}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event - Base class for events =head1 DESCRIPTION Base class for all event objects that get passed through L. =head1 SYNOPSIS package Test2::Event::MyEvent; use strict; use warnings; # This will make our class an event subclass (required) use base 'Test2::Event'; # Add some accessors (optional) # You are not obligated to use HashBase, you can use any object tool you # want, or roll your own accessors. use Test2::Util::HashBase qw/foo bar baz/; # Use this if you want the legacy API to be written for you, for this to # work you will need to implement a facet_data() method. use Test2::Util::Facets2Legacy; # Chance to initialize some defaults sub init { my $self = shift; # no other args in @_ $self->set_foo('xxx') unless defined $self->foo; ... } # This is the new way for events to convey data to the Test2 system sub facet_data { my $self = shift; # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' my $facet_data = $self->common_facet_data(); # Are you making an assertion? $facet_data->{assert} = {pass => 1, details => 'my assertion'}; ... return $facet_data; } 1; =head1 METHODS =head2 GENERAL =over 4 =item $trace = $e->trace Get a snapshot of the L as it was when this event was generated =item $bool_or_undef = $e->related($e2) Check if 2 events are related. In this case related means their traces share a signature meaning they were created with the same context (or at the very least by contexts which share an id, which is the same thing unless someone is doing something very bad). This can be used to reliably link multiple events created by the same tool. For instance a failing test like C will generate 2 events, one being a L, the other being a L, both of these events are related having been created under the same context and by the same initial tool (though multiple tools may have been nested under the initial one). This will return C if the relationship cannot be checked, which happens if either event has an incomplete or missing trace. This will return C<0> if the traces are complete, but do not match. C<1> will be returned if there is a match. =item $e->add_amnesty({tag => $TAG, details => $DETAILS}); This can be used to add amnesty to this event. Amnesty only effects failing assertions in most cases, but some formatters may display them for passing assertions, or even non-assertions as well. Amnesty will prevent a failed assertion from causing the overall test to fail. In other words it marks a failure as expected and allowed. B This is how 'TODO' is implemented under the hood. TODO is essentially amnesty with the 'TODO' tag. The details are the reason for the TODO. =back =head2 NEW API =over 4 =item $hashref = $e->common_facet_data(); This can be used by subclasses to generate a starting facet data hashref. This will populate the hashref with the trace, meta, amnesty, and about facets. These facets are nearly always produced the same way for all events. =item $hashref = $e->facet_data() If you do not override this then the default implementation will attempt to generate facets from the legacy API. This generation is limited only to what the legacy API can provide. It is recommended that you override this method and write out explicit facet data. =item $hashref = $e->facets() This takes the hashref from C and blesses each facet into the proper C subclass. =back =head3 WHAT ARE FACETS? Facets are how events convey their purpose to the Test2 internals and formatters. An event without facets will have no intentional effect on the overall test state, and will not be displayed at all by most formatters, except perhaps to say that an event of an unknown type was seen. Facets are produced by the C subroutine, which you should nearly-always override. C is expected to return a hashref where each key is the facet type, and the value is either a hashref with the data for that facet, or an array of hashref's. Some facets must be defined as single hashrefs, some must be defined as an array of hashrefs, No facets allow both. C B bless the data it returns, the main hashref, and nested facet hashref's B be bare, though items contained within each facet may be blessed. The data returned by this method B also be copies of the internal data in order to prevent accidental state modification. C takes the data from C and blesses it into the C packages. This is rarely used however, the EventFacet packages are primarily for convenience and documentation. The EventFacet classes are not used at all internally, instead the raw data is used. Here is a list of facet types by package. The packages are not used internally, but are where the documentation for each type is kept. B Every single facet type has the C<'details'> field. This field is always intended for human consumption, and when provided, should explain the 'why' for the facet. All other fields are facet specific. =over 4 =item about => {...} L This contains information about the event itself such as the event package name. The C
field for this facet is an overall summary of the event. =item assert => {...} L This facet is used if an assertion was made. The C
field of this facet is the description of the assertion. =item control => {...} L This facet is used to tell the L about special actions the event causes. Things like halting all testing, terminating the current test, etc. In this facet the C
field explains why any special action was taken. B This is how bail-out is implemented. =item meta => {...} L The meta facet contains all the meta-data attached to the event. In this case the C
field has no special meaning, but may be present if something sets the 'details' meta-key on the event. =item parent => {...} L This facet contains nested events and similar details for subtests. In this facet the C
field will typically be the name of the subtest. =item plan => {...} L This facet tells the system that a plan has been set. The C
field of this is usually left empty, but when present explains why the plan is what it is, this is most useful if the plan is to skip-all. =item trace => {...} L This facet contains information related to when and where the event was generated. This is how the test file and line number of a failure is known. This facet can also help you to tell if tests are related. In this facet the C
field overrides the "failed at test_file.t line 42." message provided on assertion failure. =item amnesty => [{...}, ...] L The amnesty facet is a list instead of a single item, this is important as amnesty can come from multiple places at once. For each instance of amnesty the C
field explains why amnesty was granted. B Outside of formatters amnesty only acts to forgive a failing assertion. =item errors => [{...}, ...] L The errors facet is a list instead of a single item, any number of errors can be listed. In this facet C
describes the error, or may contain the raw error message itself (such as an exception). In perl exception may be blessed objects, as such the raw data for this facet may contain nested items which are blessed. Not all errors are considered fatal, there is a C field that must be set for an error to cause the test to fail. B This facet is unique in that the field name is 'errors' while the package is 'Error'. This is because this is the only facet type that is both a list, and has a name where the plural is not the same as the singular. This may cause some confusion, but I feel it will be less confusing than the alternative. =item info => [{...}, ...] L The 'info' facet is a list instead of a single item, any quantity of extra information can be attached to an event. Some information may be critical diagnostics, others may be simply commentary in nature, this is determined by the C flag. For this facet the C
flag is the info itself. This info may be a string, or it may be a data structure to display. This is one of the few facet types that may contain blessed items. =back =head2 LEGACY API =over 4 =item $bool = $e->causes_fail Returns true if this event should result in a test failure. In general this should be false. =item $bool = $e->increments_count Should be true if this event should result in a test count increment. =item $e->callback($hub) If your event needs to have extra effects on the L you can override this method. This is called B your event is passed to the formatter. =item $num = $e->nested If this event is nested inside of other events, this should be the depth of nesting. (This is mainly for subtests) =item $bool = $e->global Set this to true if your event is global, that is ALL threads and processes should see it no matter when or where it is generated. This is not a common thing to want, it is used by bail-out and skip_all to end testing. =item $code = $e->terminate This is called B your event has been passed to the formatter. This should normally return undef, only change this if your event should cause the test to exit immediately. If you want this event to cause the test to exit you should return the exit code here. Exit code of 0 means exit success, any other integer means exit with failure. This is used by L to exit 0 when the plan is 'skip_all'. This is also used by L to force the test to exit with a failure. This is called after the event has been sent to the formatter in order to ensure the event is seen and understood. =item $msg = $e->summary This is intended to be a human readable summary of the event. This should ideally only be one line long, but you can use multiple lines if necessary. This is intended for human consumption. You do not need to make it easy for machines to understand. The default is to simply return the event package name. =item ($count, $directive, $reason) = $e->sets_plan() Check if this event sets the testing plan. It will return an empty list if it does not. If it does set the plan it will return a list of 1 to 3 items in order: Expected Test Count, Test Directive, Reason for directive. =item $bool = $e->diagnostics True if the event contains diagnostics info. This is useful because a non-verbose harness may choose to hide events that are not in this category. Some formatters may choose to send these to STDERR instead of STDOUT to ensure they are seen. =item $bool = $e->no_display False by default. This will return true on events that should not be displayed by formatters. =item $id = $e->in_subtest If the event is inside a subtest this should have the subtest ID. =item $id = $e->subtest_id If the event is a final subtest event, this should contain the subtest ID. =back =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Util.pm0000644000175000017500000002210213243466361017064 0ustar exodistexodistpackage Test2::Util; use strict; use warnings; our $VERSION = '1.302125'; use POSIX(); use Config qw/%Config/; use Carp qw/croak/; BEGIN { local ($@, $!, $SIG{__DIE__}); *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; } our @EXPORT_OK = qw{ try pkg_to_file get_tid USE_THREADS CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask clone_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } BEGIN { *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; } sub _can_thread { return 0 unless $] >= 5.008001; return 0 unless $Config{'useithreads'}; # Threads are broken on perl 5.10.0 built with gcc 4.8+ if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { my @parts = split /\./, $Config{'gccversion'}; return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); } # Change to a version check if this ever changes return 0 if $INC{'Devel/Cover.pm'}; return 1; } sub _can_fork { return 1 if $Config{d_fork}; return 0 unless IS_WIN32 || $^O eq 'NetWare'; return 0 unless $Config{useithreads}; return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; return _can_thread(); } BEGIN { no warnings 'once'; *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; } my $can_fork; sub CAN_FORK () { return $can_fork if defined $can_fork; $can_fork = !!_can_fork(); no warnings 'redefine'; *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; $can_fork; } my $can_really_fork; sub CAN_REALLY_FORK () { return $can_really_fork if defined $can_really_fork; $can_really_fork = !!$Config{d_fork}; no warnings 'redefine'; *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; $can_really_fork; } sub _manual_try(&;@) { my $code = shift; my $args = \@_; my $err; my $die = delete $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; return (!defined($err), $err); } sub _local_try(&;@) { my $code = shift; my $args = \@_; my $err; no warnings; local $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; return (!defined($err), $err); } # Older versions of perl have a nasty bug on win32 when localizing a variable # before forking or starting a new thread. So for those systems we use the # non-local form. When possible though we use the faster 'local' form. BEGIN { if (IS_WIN32 && $] < 5.020002) { *try = \&_manual_try; } else { *try = \&_local_try; } } BEGIN { if (CAN_THREAD) { if ($INC{'threads.pm'}) { # Threads are already loaded, so we do not need to check if they # are loaded each time *USE_THREADS = sub() { 1 }; *get_tid = sub() { threads->tid() }; } else { # :-( Need to check each time to see if they have been loaded. *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; } } else { # No threads, not now, not ever! *USE_THREADS = sub() { 0 }; *get_tid = sub() { 0 }; } } sub pkg_to_file { my $pkg = shift; my $file = $pkg; $file =~ s{(::|')}{/}g; $file .= '.pm'; return $file; } sub ipc_separator() { "~" } sub _check_for_sig_sys { my $sig_list = shift; return $sig_list =~ m/\bSYS\b/; } BEGIN { if (_check_for_sig_sys($Config{sig_name})) { *CAN_SIGSYS = sub() { 1 }; } else { *CAN_SIGSYS = sub() { 0 }; } } my %PERLIO_SKIP = ( unix => 1, via => 1, ); sub clone_io { my ($fh) = @_; my $fileno = fileno($fh); return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; my %seen; my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); binmode($out, join(":", "", "raw", @layers)); my $old = select $fh; my $af = $|; select $out; $| = $af; select $old; return $out; } BEGIN { if (IS_WIN32) { my $max_tries = 5; *do_rename = sub { my ($from, $to) = @_; my $err; for (1 .. $max_tries) { return (1) if rename($from, $to); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, $err); }; *do_unlink = sub { my ($file) = @_; my $err; for (1 .. $max_tries) { return (1) if unlink($file); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, "$!"); }; } else { *do_rename = sub { my ($from, $to) = @_; return (1) if rename($from, $to); return (0, "$!"); }; *do_unlink = sub { my ($file) = @_; return (1) if unlink($file); return (0, "$!"); }; } } sub try_sig_mask(&) { my $code = shift; my ($old, $blocked); unless(IS_WIN32) { my $to_block = POSIX::SigSet->new( POSIX::SIGINT(), POSIX::SIGALRM(), POSIX::SIGHUP(), POSIX::SIGTERM(), POSIX::SIGUSR1(), POSIX::SIGUSR2(), ); $old = POSIX::SigSet->new; $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); # Silently go on if we failed to log signals, not much we can do. } my ($ok, $err) = &try($code); # If our block was successful we want to restore the old mask. POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; return ($ok, $err); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util - Tools used by Test2 and friends. =head1 DESCRIPTION Collection of tools used by L and friends. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item ($success, $error) = try { ... } Eval the codeblock, return success or failure, and the error message. This code protects $@ and $!, they will be restored by the end of the run. This code also temporarily blocks $SIG{DIE} handlers. =item protect { ... } Similar to try, except that it does not catch exceptions. The idea here is to protect $@ and $! from changes. $@ and $! will be restored to whatever they were before the run so long as it is successful. If the run fails $! will still be restored, but $@ will contain the exception being thrown. =item CAN_FORK True if this system is capable of true or pseudo-fork. =item CAN_REALLY_FORK True if the system can really fork. This will be false for systems where fork is emulated. =item CAN_THREAD True if this system is capable of using threads. =item USE_THREADS Returns true if threads are enabled, false if they are not. =item get_tid This will return the id of the current thread when threads are enabled, otherwise it returns 0. =item my $file = pkg_to_file($package) Convert a package name to a filename. =item ($ok, $err) = do_rename($old_name, $new_name) Rename a file, this wraps C in a way that makes it more reliable cross-platform when trying to rename files you recently altered. =item ($ok, $err) = do_unlink($filename) Unlink a file, this wraps C in a way that makes it more reliable cross-platform when trying to unlink files you recently altered. =item ($ok, $err) = try_sig_mask { ... } Complete an action with several signals masked, they will be unmasked at the end allowing any signals that were intercepted to get handled. This is primarily used when you need to make several actions atomic (against some signals anyway). Signals that are intercepted: =over 4 =item SIGINT =item SIGALRM =item SIGHUP =item SIGTERM =item SIGUSR1 =item SIGUSR2 =back =back =head1 NOTES && CAVEATS =over 4 =item 5.10.0 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a segfault whenever a new thread is launched. Test2 will attempt to detect this, and note that the system is not capable of forking when it is detected. =item Devel::Cover Devel::Cover does not support threads. CAN_THREAD will return false if Devel::Cover is loaded before the check is first run. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/Hub.pm0000644000175000017500000005332413243466361016677 0ustar exodistexodistpackage Test2::Hub; use strict; use warnings; our $VERSION = '1.302125'; use Carp qw/carp croak confess/; use Test2::Util qw/get_tid ipc_separator/; use Scalar::Util qw/weaken/; use List::Util qw/first/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ pid tid hid ipc nested buffered no_ending _filters _pre_filters _listeners _follow_ups _formatter _context_acquire _context_init _context_release active count failed ended bailed_out _passing _plan skip_reason }; my $ID_POSTFIX = 1; sub init { my $self = shift; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; $self->{+NESTED} = 0 unless defined $self->{+NESTED}; $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; if (my $formatter = delete $self->{formatter}) { $self->format($formatter); } if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub is_subtest { 0 } sub _tb_reset { my $self = shift; # Nothing to do return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub reset_state { my $self = shift; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; delete $self->{+_PLAN}; delete $self->{+ENDED}; delete $self->{+BAILED_OUT}; delete $self->{+SKIP_REASON}; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} ||= 0; $self->{+_FORMATTER} = $from->{+_FORMATTER} unless $self->{+_FORMATTER} || exists($params{formatter}); if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; } if (my $pfs = $from->{+_PRE_FILTERS}) { push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; } if (my $fs = $from->{+_FILTERS}) { push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; } } sub format { my $self = shift; my $old = $self->{+_FORMATTER}; ($self->{+_FORMATTER}) = @_ if @_; return $old; } sub is_local { my $self = shift; return $$ == $self->{+PID} && get_tid() == $self->{+TID}; } sub listen { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "listen only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_LISTENERS}} => { %params, code => $sub }; $sub; # Intentional return. } sub unlisten { my $self = shift; carp "Useless removal of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; } sub filter { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub unfilter { my $self = shift; carp "Useless removal of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; } sub pre_filter { my $self = shift; my ($sub, %params) = @_; croak "pre_filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub pre_unfilter { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; } sub follow_up { my $self = shift; my ($sub) = @_; carp "Useless addition of a follow-up in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "follow_up only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FOLLOW_UPS}} => $sub; } *add_context_aquire = \&add_context_acquire; sub add_context_acquire { my $self = shift; my ($sub) = @_; croak "add_context_acquire only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; $sub; # Intentional return. } *remove_context_aquire = \&remove_context_acquire; sub remove_context_acquire { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}}; } sub add_context_init { my $self = shift; my ($sub) = @_; croak "add_context_init only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_INIT}} => $sub; $sub; # Intentional return. } sub remove_context_init { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; } sub add_context_release { my $self = shift; my ($sub) = @_; croak "add_context_release only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_RELEASE}} => $sub; $sub; # Intentional return. } sub remove_context_release { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; } sub send { my $self = shift; my ($e) = @_; if ($self->{+_PRE_FILTERS}) { for (@{$self->{+_PRE_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } my $ipc = $self->{+IPC} || return $self->process($e); if($e->global) { $ipc->send($self->{+HID}, $e, 'GLOBAL'); return $self->process($e); } return $ipc->send($self->{+HID}, $e) if $$ != $self->{+PID} || get_tid() != $self->{+TID}; $self->process($e); } sub process { my $self = shift; my ($e) = @_; if ($self->{+_FILTERS}) { for (@{$self->{+_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } # Optimize the most common case my $type = ref($e); if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { my $count = ++($self->{+COUNT}); $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; } return $e; } my $f = $e->facet_data; my $fail = 0; $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}}; $fail = 0 if $f->{amnesty}; $self->{+COUNT}++ if $f->{assert}; $self->{+FAILED}++ if $fail && $f->{assert}; $self->{+_PASSING} = 0 if $fail; my $code = $f->{control}->{terminate}; my $count = $self->{+COUNT}; if (my $plan = $f->{plan}) { if ($plan->{skip}) { $self->plan('SKIP'); $self->set_skip_reason($plan->{details} || 1); $code ||= 0; } elsif ($plan->{none}) { $self->plan('NO PLAN'); } else { $self->plan($plan->{count}); } } $e->callback($self) if $f->{control}->{has_callback}; $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; } if ($f->{control}->{halt}) { $code ||= 255; $self->set_bailed_out($e); } if (defined $code) { $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; $self->terminate($code, $e, $f); } return $e; } sub terminate { my $self = shift; my ($code) = @_; exit($code); } sub cull { my $self = shift; my $ipc = $self->{+IPC} || return; return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); # No need to do IPC checks on culled events $self->process($_) for $ipc->cull($self->{+HID}); } sub finalize { my $self = shift; my ($trace, $do_plan) = @_; $self->cull(); my $plan = $self->{+_PLAN}; my $count = $self->{+COUNT}; my $failed = $self->{+FAILED}; my $active = $self->{+ACTIVE}; # return if NOTHING was done. unless ($active || $do_plan || defined($plan) || $count || $failed) { $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; return; } unless ($self->{+ENDED}) { if ($self->{+_FOLLOW_UPS}) { $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; } # These need to be refreshed now $plan = $self->{+_PLAN}; $count = $self->{+COUNT}; $failed = $self->{+FAILED}; if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { $self->send( Test2::Event::Plan->new( trace => $trace, max => $count, ) ); } $plan = $self->{+_PLAN}; } my $frame = $trace->frame; if($self->{+ENDED}) { my (undef, $ffile, $fline) = @{$self->{+ENDED}}; my (undef, $sfile, $sline) = @$frame; die <<" EOT" Test already ended! First End: $ffile line $fline Second End: $sfile line $sline EOT } $self->{+ENDED} = $frame; my $pass = $self->is_passing(); # Generate the final boolean. $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; return $pass; } sub is_passing { my $self = shift; ($self->{+_PASSING}) = @_ if @_; # If we already failed just return 0. my $pass = $self->{+_PASSING} or return 0; return $self->{+_PASSING} = 0 if $self->{+FAILED}; my $count = $self->{+COUNT}; my $ended = $self->{+ENDED}; my $plan = $self->{+_PLAN}; return $pass if !$count && $plan && $plan =~ m/^SKIP$/; return $self->{+_PASSING} = 0 if $ended && (!$count || !$plan); return $pass unless $plan && $plan =~ m/^\d+$/; if ($ended) { return $self->{+_PASSING} = 0 if $count != $plan; } else { return $self->{+_PASSING} = 0 if $count > $plan; } return $pass; } sub plan { my $self = shift; return $self->{+_PLAN} unless @_; my ($plan) = @_; confess "You cannot unset the plan" unless defined $plan; confess "You cannot change the plan" if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; $self->{+_PLAN} = $plan; } sub check_plan { my $self = shift; return undef unless $self->{+ENDED}; my $plan = $self->{+_PLAN} || return undef; return 1 if $plan !~ m/^\d+$/; return 1 if $plan == $self->{+COUNT}; return 0; } sub DESTROY { my $self = shift; my $ipc = $self->{+IPC} || return; return unless $$ == $self->{+PID}; return unless get_tid() == $self->{+TID}; $ipc->drop_hub($self->{+HID}); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub - The conduit through which all events flow. =head1 SYNOPSIS use Test2::Hub; my $hub = Test2::Hub->new(); $hub->send(...); =head1 DESCRIPTION The hub is the place where all events get processed and handed off to the formatter. The hub also tracks test state, and provides several hooks into the event pipeline. =head1 COMMON TASKS =head2 SENDING EVENTS $hub->send($event) The C method is used to issue an event to the hub. This method will handle thread/fork sync, filters, listeners, TAP output, etc. =head2 ALTERING OR REMOVING EVENTS You can use either C or C, depending on your needs. Both have identical syntax, so only C is shown here. $hub->filter(sub { my ($hub, $event) = @_; my $action = get_action($event); # No action should be taken return $event if $action eq 'none'; # You want your filter to remove the event return undef if $action eq 'delete'; if ($action eq 'do_it') { my $new_event = copy_event($event); ... Change your copy of the event ... return $new_event; } die "Should not happen"; }); By default, filters are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the filter. You can change this behavior with the C parameter: $hub->filter(sub { ... }, inherit => 1); =head2 LISTENING FOR EVENTS $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); By default listeners are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the listener. You can change this behavior with the C parameter: $hub->listen(sub { ... }, inherit => 1); =head2 POST-TEST BEHAVIORS $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, either when done_testing is called, or in an END block. =head2 SETTING THE FORMATTER By default an instance of L is created and used. my $old = $hub->format(My::Formatter->new); Setting the formatter will REPLACE any existing formatter. You may set the formatter to undef to prevent output. The old formatter will be returned if one was already set. Only one formatter is allowed at a time. =head1 METHODS =over 4 =item $hub->send($event) This is where all events enter the hub for processing. =item $hub->process($event) This is called by send after it does any IPC handling. You can use this to bypass the IPC process, but in general you should avoid using this. =item $old = $hub->format($formatter) Replace the existing formatter instance with a new one. Formatters must be objects that implement a C<< $formatter->write($event) >> method. =item $sub = $hub->listen(sub { ... }, %optional_params) You can use this to record all events AFTER they have been sent to the formatter. No changes made here will be meaningful, except possibly to other listeners. $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); Normally listeners are not inherited by child hubs such as subtests. You can add the C<< inherit => 1 >> parameter to allow a listener to be inherited. =item $hub->unlisten($sub) You can use this to remove a listen callback. You must pass in the coderef returned by the C method. =item $sub = $hub->filter(sub { ... }, %optional_params) =item $sub = $hub->pre_filter(sub { ... }, %optional_params) These can be used to add filters. Filters can modify, replace, or remove events before anything else can see them. $hub->filter( sub { my ($hub, $event) = @_; return $event; # No Changes return; # Remove the event # Or you can modify an event before returning it. $event->modify; return $event; } ); If you are not using threads, forking, or IPC then the only difference between a C and a C is that C subs run first. When you are using threads, forking, or IPC, pre_filters happen to events before they are sent to their destination proc/thread, ordinary filters happen only in the destination hub/thread. You cannot add a regular filter to a hub if the hub was created in another process or thread. You can always add a pre_filter. =item $hub->unfilter($sub) =item $hub->pre_unfilter($sub) These can be used to remove filters and pre_filters. The C<$sub> argument is the reference returned by C or C. =item $hub->follow_op(sub { ... }) Use this to add behaviors that are called just before the hub is finalized. The only argument to your codeblock will be a L instance. $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, ether when done_testing is called, or in an END block. =item $sub = $hub->add_context_acquire(sub { ... }); Add a callback that will be called every time someone tries to acquire a context. It gets a single argument, a reference of the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_acquire($sub); This can be used to remove a context acquire hook. =item $sub = $hub->add_context_init(sub { ... }); This allows you to add callbacks that will trigger every time a new context is created for the hub. The only argument to the sub will be the L instance that was created. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_init($sub); This can be used to remove a context init hook. =item $sub = $hub->add_context_release(sub { ... }); This allows you to add callbacks that will trigger every time a context for this hub is released. The only argument to the sub will be the L instance that was released. These will run in reverse order. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_release($sub); This can be used to remove a context release hook. =item $hub->cull() Cull any IPC events (and process them). =item $pid = $hub->pid() Get the process id under which the hub was created. =item $tid = $hub->tid() Get the thread id under which the hub was created. =item $hud = $hub->hid() Get the identifier string of the hub. =item $ipc = $hub->ipc() Get the IPC object used by the hub. =item $hub->set_no_ending($bool) =item $bool = $hub->no_ending This can be used to disable auto-ending behavior for a hub. The auto-ending behavior is triggered by an end block and is used to cull IPC events, and output the final plan if the plan was 'no_plan'. =item $bool = $hub->active =item $hub->set_active($bool) These are used to get/set the 'active' attribute. When true this attribute will force C<< hub->finalize() >> to take action even if there is no plan, and no tests have been run. This flag is useful for plugins that add follow-up behaviors that need to run even if no events are seen. =back =head2 STATE METHODS =over 4 =item $hub->reset_state() Reset all state to the start. This sets the test count to 0, clears the plan, removes the failures, etc. =item $num = $hub->count Get the number of tests that have been run. =item $num = $hub->failed Get the number of failures (Not all failures come from a test fail, so this number can be larger than the count). =item $bool = $hub->ended True if the testing has ended. This MAY return the stack frame of the tool that ended the test, but that is not guaranteed. =item $bool = $hub->is_passing =item $hub->is_passing($bool) Check if the overall test run is a failure. Can also be used to set the pass/fail status. =item $hub->plan($plan) =item $plan = $hub->plan Get or set the plan. The plan must be an integer larger than 0, the string 'no_plan', or the string 'skip_all'. =item $bool = $hub->check_plan Check if the plan and counts match, but only if the tests have ended. If tests have not ended this will return undef, otherwise it will be a true/false. =back =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/IPC.pm0000644000175000017500000000550613243466361016573 0ustar exodistexodistpackage Test2::IPC; use strict; use warnings; our $VERSION = '1.302125'; use Test2::API::Instance; use Test2::Util qw/get_tid/; use Test2::API qw{ test2_init_done test2_ipc test2_has_ipc test2_ipc_enable_polling test2_pid test2_stack test2_tid context }; use Carp qw/confess/; our @EXPORT_OK = qw/cull/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub unimport { Test2::API::test2_ipc_disable() } sub import { goto &Exporter::import if test2_has_ipc || !test2_init_done(); confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); Test2::API::_set_ipc(_make_ipc()); apply_ipc(test2_stack()); goto &Exporter::import; } sub _make_ipc { # Find a driver my ($driver) = Test2::API::test2_ipc_drivers(); unless ($driver) { require Test2::IPC::Driver::Files; $driver = 'Test2::IPC::Driver::Files'; } return $driver->new(); } sub apply_ipc { my $stack = shift; my ($root) = @$stack; return unless $root; confess "Cannot add IPC in a child process" if $root->pid != $$; confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); my $ipc = $root->ipc || test2_ipc() || _make_ipc(); # Add the IPC to all hubs for my $hub (@$stack) { my $has = $hub->ipc; confess "IPC Mismatch!" if $has && $has != $ipc; next if $has; $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } test2_ipc_enable_polling(); return $ipc; } sub cull { my $ctx = context(); $ctx->hub->cull; $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC - Turn on IPC for threading or forking support. =head1 SYNOPSIS You should C as early as possible in your test file. If you import this module after API initialization it will attempt to retrofit IPC onto the existing hubs. =head2 DISABLING IT You can use C to disable IPC for good. You can also use the T2_NO_IPC env var. =head1 EXPORTS All exports are optional. =over 4 =item cull() Cull allows you to collect results from other processes or threads on demand. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test2/API.pm0000644000175000017500000012631313243466361016571 0ustar exodistexodistpackage Test2::API; use strict; use warnings; use Test2::Util qw/USE_THREADS/; BEGIN { $ENV{TEST_ACTIVE} ||= 1; $ENV{TEST2_ACTIVE} = 1; } our $VERSION = '1.302125'; my $INST; my $ENDING = 0; sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } sub test2_get_is_end { $ENDING } use Test2::API::Instance(\$INST); # Set the exit status END { test2_set_is_end(); # See gh #16 $INST->set_exit(); } sub CLONE { my $init = test2_init_done(); my $load = test2_load_done(); return if $init && $load; require Carp; Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; } # See gh #16 { no warnings; INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } } BEGIN { no warnings 'once'; if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { *DO_DEPTH_CHECK = sub() { 1 }; } else { *DO_DEPTH_CHECK = sub() { 0 }; } } use Test2::EventFacet::Trace(); use Test2::Util::Trace(); # Legacy use Test2::Hub::Subtest(); use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); use Test2::Event::Ok(); use Test2::Event::Diag(); use Test2::Event::Note(); use Test2::Event::Plan(); use Test2::Event::Bail(); use Test2::Event::Exception(); use Test2::Event::Waiting(); use Test2::Event::Skip(); use Test2::Event::Subtest(); use Carp qw/carp croak confess/; use Scalar::Util qw/blessed weaken/; use Test2::Util qw/get_tid clone_io pkg_to_file/; our @EXPORT_OK = qw{ context release context_do no_context intercept intercept_deep run_subtest test2_init_done test2_load_done test2_load test2_start_preload test2_stop_preload test2_in_preload test2_set_is_end test2_get_is_end test2_pid test2_tid test2_stack test2_no_wait test2_ipc_wait_enable test2_ipc_wait_disable test2_ipc_wait_enabled test2_add_callback_context_aquire test2_add_callback_context_acquire test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_add_callback_pre_subtest test2_list_context_aquire_callbacks test2_list_context_acquire_callbacks test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_list_pre_subtest_callbacks test2_ipc test2_has_ipc test2_ipc_disable test2_ipc_disabled test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_ipc_get_pending test2_ipc_set_pending test2_ipc_get_timeout test2_ipc_set_timeout test2_ipc_enable_shm test2_formatter test2_formatters test2_formatter_add test2_formatter_set test2_stdout test2_stderr test2_reset_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } my $STACK = $INST->stack; my $CONTEXTS = $INST->contexts; my $INIT_CBS = $INST->context_init_callbacks; my $ACQUIRE_CBS = $INST->context_acquire_callbacks; my $STDOUT = clone_io(\*STDOUT); my $STDERR = clone_io(\*STDERR); sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } sub test2_post_preload_reset { test2_reset_io(); $INST->post_preload_reset; } sub test2_reset_io { $STDOUT = clone_io(\*STDOUT); $STDERR = clone_io(\*STDERR); } sub test2_init_done { $INST->finalized } sub test2_load_done { $INST->loaded } sub test2_load { $INST->load } sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } sub test2_in_preload { $INST->preload } sub test2_pid { $INST->pid } sub test2_tid { $INST->tid } sub test2_stack { $INST->stack } sub test2_ipc_wait_enable { $INST->set_no_wait(0) } sub test2_ipc_wait_disable { $INST->set_no_wait(1) } sub test2_ipc_wait_enabled { !$INST->no_wait } sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; } sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } sub test2_add_callback_exit { $INST->add_exit_callback(@_) } sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) } sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} } sub test2_ipc { $INST->ipc } sub test2_has_ipc { $INST->has_ipc } sub test2_ipc_disable { $INST->ipc_disable } sub test2_ipc_disabled { $INST->ipc_disabled } sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } sub test2_ipc_drivers { @{$INST->ipc_drivers} } sub test2_ipc_polling { $INST->ipc_polling } sub test2_ipc_enable_polling { $INST->enable_ipc_polling } sub test2_ipc_disable_polling { $INST->disable_ipc_polling } sub test2_ipc_get_pending { $INST->get_ipc_pending } sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) } sub test2_ipc_get_timeout { $INST->ipc_timeout() } sub test2_ipc_enable_shm { $INST->ipc_enable_shm } sub test2_formatter { if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { my $formatter = $1 ? $2 : "Test2::Formatter::$2"; my $file = pkg_to_file($formatter); require $file; return $formatter; } return $INST->formatter; } sub test2_formatters { @{$INST->formatters} } sub test2_formatter_add { $INST->add_formatter(@_) } sub test2_formatter_set { my ($formatter) = @_; croak "No formatter specified" unless $formatter; croak "Global Formatter already set" if $INST->formatter_set; $INST->set_formatter($formatter); } # Private, for use in Test2::API::Context sub _contexts_ref { $INST->contexts } sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } sub _context_init_callbacks_ref { $INST->context_init_callbacks } sub _context_release_callbacks_ref { $INST->context_release_callbacks } # Private, for use in Test2::IPC sub _set_ipc { $INST->set_ipc(@_) } sub context_do(&;@) { my $code = shift; my @args = @_; my $ctx = context(level => 1); my $want = wantarray; my @out; my $ok = eval { $want ? @out = $code->($ctx, @args) : defined($want) ? $out[0] = $code->($ctx, @args) : $code->($ctx, @args) ; 1; }; my $err = $@; $ctx->release; die $err unless $ok; return @out if $want; return $out[0] if defined $want; return; } sub no_context(&;$) { my ($code, $hid) = @_; $hid ||= $STACK->top->hid; my $ctx = $CONTEXTS->{$hid}; delete $CONTEXTS->{$hid}; my $ok = eval { $code->(); 1 }; my $err = $@; $CONTEXTS->{$hid} = $ctx; weaken($CONTEXTS->{$hid}); die $err unless $ok; return; }; my $CID = 1; sub context { # We need to grab these before anything else to ensure they are not # changed. my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E); my %params = (level => 0, wrapped => 0, @_); # If something is getting a context then the sync system needs to be # considered loaded... $INST->load unless $INST->{loaded}; croak "context() called, but return value is ignored" unless defined wantarray; my $stack = $params{stack} || $STACK; my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; $_->(\%params) for @$ACQUIRE_CBS; map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 my $phase = ${^GLOBAL_PHASE} || 'NA'; my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; my $level = 1 + $params{level}; my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level); unless ($pkg || $end_phase) { confess "Could not find context at depth $level" unless $params{fudge}; ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg); } my $depth = $level; $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); $depth -= $params{wrapped}; my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; if ($current && $params{on_release} && $depth_ok) { $current->{_on_release} ||= []; push @{$current->{_on_release}} => $params{on_release}; } # I know this is ugly.... ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless( { %$current, _is_canon => undef, errno => $errno, eval_error => $eval_error, child_error => $child_error, _is_spawn => [$pkg, $file, $line, $sub], }, 'Test2::API::Context' ) if $current && $depth_ok; # Handle error condition of bad level if ($current) { unless (${$current->{_aborted}}) { _canon_error($current, [$pkg, $file, $line, $sub, $depth]) unless $current->{_is_canon}; _depth_error($current, [$pkg, $file, $line, $sub, $depth]) unless $depth_ok; } $current->release if $current->{_is_canon}; delete $CONTEXTS->{$hid}; } # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $trace = bless( { frame => [$pkg, $file, $line, $sub], pid => $$, tid => get_tid(), cid => 'C' . $CID++, hid => $hid, nested => $hub->{nested}, buffered => $hub->{buffered}, }, 'Test2::EventFacet::Trace' ); # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $aborted = 0; $current = bless( { _aborted => \$aborted, stack => $stack, hub => $hub, trace => $trace, _is_canon => 1, _depth => $depth, errno => $errno, eval_error => $eval_error, child_error => $child_error, $params{on_release} ? (_on_release => [$params{on_release}]) : (), }, 'Test2::API::Context' ); $CONTEXTS->{$hid} = $current; weaken($CONTEXTS->{$hid}); $_->($current) for @$INIT_CBS; map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; $params{on_init}->($current) if $params{on_init}; ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error); return $current; } sub _depth_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context was created in a stack frame at the same, or deeper level. This usually means that a tool failed to release the context when it was finished. EOT } sub _canon_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context has an invalid internal state (!_canon_count). This should not normally happen unless something is mucking about with internals... EOT } sub _existing_error { my ($ctx, $details, $msg) = @_; my ($pkg, $file, $line, $sub, $depth) = @$details; my $oldframe = $ctx->{trace}->frame; my $olddepth = $ctx->{_depth}; # Older versions of Carp do not export longmess() function, so it needs to be called with package name my $mess = Carp::longmess(); warn <<" EOT"; $msg Old context details: File: $oldframe->[1] Line: $oldframe->[2] Tool: $oldframe->[3] Depth: $olddepth New context details: File: $file Line: $line Tool: $sub Depth: $depth Trace: $mess Removing the old context and creating a new one... EOT } sub release($;$) { $_[0]->release; return $_[1]; } sub intercept(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 0); $ctx->release; return $events; } sub intercept_deep(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 1); $ctx->release; return $events; } sub _intercept { my $code = shift; my %params = @_; my $ctx = context(); my $ipc; if (my $global_ipc = test2_ipc()) { my $driver = blessed($global_ipc); $ipc = $driver->new; } my $hub = Test2::Hub::Interceptor->new( ipc => $ipc, no_ending => 1, ); my @events; $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep}); $ctx->stack->top; # Make sure there is a top hub before we begin. $ctx->stack->push($hub); my ($ok, $err) = (1, undef); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { $ok = 1; $err = undef; } } $hub->cull; $ctx->stack->pop($hub); my $trace = $ctx->trace; $ctx->release; die $err unless $ok; $hub->finalize($trace, 1) if $ok && !$hub->no_ending && !$hub->ended; return \@events; } sub run_subtest { my ($name, $code, $params, @args) = @_; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $params = {buffered => $params} unless ref $params; my $inherit_trace = delete $params->{inherit_trace}; my $ctx = context(); my $parent = $ctx->hub; # If a parent is buffered then the child must be as well. my $buffered = $params->{buffered} || $parent->{buffered}; $ctx->note($name) unless $buffered; my $stack = $ctx->stack || $STACK; my $hub = $stack->new_hub( class => 'Test2::Hub::Subtest', %$params, buffered => $buffered, ); my @events; $hub->listen(sub { push @events => $_[1] }); if ($buffered) { if (my $format = $hub->format) { my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; $hub->format(undef) if $hide; } } if ($inherit_trace) { my $orig = $code; $code = sub { my $base_trace = $ctx->trace; my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested); my $st_ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); $st_ctx->do_in_context($orig, @args); }; } my ($ok, $err, $finished); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(@args); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } if ($params->{no_fork}) { if ($$ != $ctx->trace->pid) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } if (get_tid() != $ctx->trace->tid) { warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; exit 255; } } elsif (!$parent->is_local && !$parent->ipc) { warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; exit 255; } $stack->pop($hub); my $trace = $ctx->trace; my $bailed = $hub->bailed_out; if (!$finished) { if ($bailed && !$buffered) { $ctx->bail($bailed->reason); } elsif ($bailed && $buffered) { $ok = 1; } else { my $code = $hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } } $hub->finalize($trace->snapshot(hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1) if $ok && !$hub->no_ending && !$hub->ended; my $pass = $ok && $hub->is_passing; my $e = $ctx->build_event( 'Subtest', pass => $pass, name => $name, subtest_id => $hub->id, buffered => $buffered, subevents => \@events, ); my $plan_ok = $hub->check_plan; $ctx->hub->send($e); $ctx->failure_diag($e) unless $e->pass; $ctx->diag("Caught exception in subtest: $err") unless $ok; $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) if defined($plan_ok) && !$plan_ok; $ctx->bail($bailed->reason) if $bailed && $buffered; $ctx->release; return $pass; } # There is a use-cycle between API and API/Context. Context needs to use some # API functions as the package is compiling. Test2::API::context() needs # Test2::API::Context to be loaded, but we cannot 'require' the module there as # it causes a very noticeable performance impact with how often context() is # called. require Test2::API::Context; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API - Primary interface for writing Test2 based testing tools. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwards-incompatible ways (once there is a stable release), but the underlying implementation details might. B Currently the implementation is to create a single instance of the L Object. All class methods defer to the single instance. There is no public access to the singleton, and that is intentional. The class methods provided by this package provide the only functionality publicly exposed. This is done primarily to avoid the problems Test::Builder had by exposing its singleton. We do not want anyone to replace this singleton, rebless it, or directly muck with its internals. If you need to do something and cannot because of the restrictions placed here, then please report it as an issue. If possible, we will create a way for you to implement your functionality without exposing things that should not be exposed. =head1 DESCRIPTION This package exports all the functions necessary to write and/or verify testing tools. Using these building blocks you can begin writing test tools very quickly. You are also provided with tools that help you to test the tools you write. =head1 SYNOPSIS =head2 WRITING A TOOL The C method is your primary interface into the Test2 framework. package My::Ok; use Test2::API qw/context/; our @EXPORT = qw/my_ok/; use base 'Exporter'; # Just like ok() from Test::More sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); # Get a context $ctx->ok($bool, $name); $ctx->release; # Release the context return $bool; } See L for a list of methods available on the context object. =head2 TESTING YOUR TOOLS The C tool lets you temporarily intercept all events generated by the test system: use Test2::API qw/intercept/; use My::Ok qw/my_ok/; my $events = intercept { # These events are not displayed my_ok(1, "pass"); my_ok(0, "fail"); }; my_ok(@$events == 2, "got 2 events, the pass and the fail"); my_ok($events->[0]->pass, "first event passed"); my_ok(!$events->[1]->pass, "second event failed"); =head3 DEEP EVENT INTERCEPTION Normally C only intercepts events sent to the main hub (as added by intercept itself). Nested hubs, such as those created by subtests, will not be intercepted. This is normally what you will still see the nested events by inspecting the subtest event. However there are times where you want to verify each event as it is sent, in that case use C. my $events = intercept_Deep { buffered_subtest foo => sub { ok(1, "pass"); }; }; C<$events> in this case will contain 3 items: =over 4 =item The event from C =item The plan event for the subtest =item The subtest event itself, with the first 2 events nested inside it as children. =back This lets you see the order in which the events were sent, unlike C which only lets you see events as the main hub sees them. =head2 OTHER API FUNCTIONS use Test2::API qw{ test2_init_done test2_stack test2_set_is_end test2_get_is_end test2_ipc test2_formatter_set test2_formatter }; my $init = test2_init_done(); my $stack = test2_stack(); my $ipc = test2_ipc(); test2_formatter_set($FORMATTER) my $formatter = test2_formatter(); ... And others ... =head1 MAIN API EXPORTS All exports are optional. You must specify subs to import. use Test2::API qw/context intercept run_subtest/; This is the list of exports that are most commonly needed. If you are simply writing a tool, then this is probably all you need. If you need something and you cannot find it here, then you can also look at L. These exports lack the 'test2_' prefix because of how important/common they are. Exports in the L section have the 'test2_' prefix to ensure they stand out. =head2 context(...) Usage: =over 4 =item $ctx = context() =item $ctx = context(%params) =back The C function will always return the current context. If there is already a context active, it will be returned. If there is not an active context, one will be generated. When a context is generated it will default to using the file and line number where the currently running sub was called from. Please see L for important rules about what you can and cannot do with a context once it is obtained. B This function will throw an exception if you ignore the context object it returns. B On perls 5.14+ a depth check is used to insure there are no context leaks. This cannot be safely done on older perls due to L You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or C<$Test2::API::DO_DEPTH_CHECK = 1> B loading L. =head3 OPTIONAL PARAMETERS All parameters to C are optional. =over 4 =item level => $int If you must obtain a context in a sub deeper than your entry point you can use this to tell it how many EXTRA stack frames to look back. If this option is not provided the default of C<0> is used. sub third_party_tool { my $sub = shift; ... # Does not obtain a context $sub->(); ... } third_party_tool(sub { my $ctx = context(level => 1); ... $ctx->release; }); =item wrapped => $int Use this if you need to write your own tool that wraps a call to C with the intent that it should return a context object. sub my_context { my %params = ( wrapped => 0, @_ ); $params{wrapped}++; my $ctx = context(%params); ... return $ctx; } sub my_tool { my $ctx = my_context(); ... $ctx->release; } If you do not do this, then tools you call that also check for a context will notice that the context they grabbed was created at the same stack depth, which will trigger protective measures that warn you and destroy the existing context. =item stack => $stack Normally C looks at the global hub stack. If you are maintaining your own L instance you may pass it in to be used instead of the global one. =item hub => $hub Use this parameter if you want to obtain the context for a specific hub instead of whatever one happens to be at the top of the stack. =item on_init => sub { ... } This lets you provide a callback sub that will be called B if your call to C generated a new context. The callback B be called if C is returning an existing context. The only argument passed into the callback will be the context object itself. sub foo { my $ctx = context(on_init => sub { 'will run' }); my $inner = sub { # This callback is not run since we are getting the existing # context from our parent sub. my $ctx = context(on_init => sub { 'will NOT run' }); $ctx->release; } $inner->(); $ctx->release; } =item on_release => sub { ... } This lets you provide a callback sub that will be called when the context instance is released. This callback will be added to the returned context even if an existing context is returned. If multiple calls to context add callbacks, then all will be called in reverse order when the context is finally released. sub foo { my $ctx = context(on_release => sub { 'will run second' }); my $inner = sub { my $ctx = context(on_release => sub { 'will run first' }); # Neither callback runs on this release $ctx->release; } $inner->(); # Both callbacks run here. $ctx->release; } =back =head2 release($;$) Usage: =over 4 =item release $ctx; =item release $ctx, ...; =back This is intended as a shortcut that lets you release your context and return a value in one statement. This function will get your context, and an optional return value. It will release your context, then return your value. Scalar context is always assumed. sub tool { my $ctx = context(); ... return release $ctx, 1; } This tool is most useful when you want to return the value you get from calling a function that needs to see the current context: my $ctx = context(); my $out = some_tool(...); $ctx->release; return $out; We can combine the last 3 lines of the above like so: my $ctx = context(); release $ctx, some_tool(...); =head2 context_do(&;@) Usage: sub my_tool { context_do { my $ctx = shift; my (@args) = @_; $ctx->ok(1, "pass"); ... # No need to call $ctx->release, done for you on scope exit. } @_; } Using this inside your test tool takes care of a lot of boilerplate for you. It will ensure a context is acquired. It will capture and rethrow any exception. It will insure the context is released when you are done. It preserves the subroutine call context (array, scalar, void). This is the safest way to write a test tool. The only two downsides to this are a slight performance decrease, and some extra indentation in your source. If the indentation is a problem for you then you can take a peek at the next section. =head2 no_context(&;$) Usage: =over 4 =item no_context { ... }; =item no_context { ... } $hid; sub my_tool(&) { my $code = shift; my $ctx = context(); ... no_context { # Things in here will not see our current context, they get a new # one. $code->(); }; ... $ctx->release; }; =back This tool will hide a context for the provided block of code. This means any tools run inside the block will get a completely new context if they acquire one. The new context will be inherited by tools nested below the one that acquired it. This will normally hide the current context for the top hub. If you need to hide the context for a different hub you can pass in the optional C<$hid> parameter. =head2 intercept(&) Usage: my $events = intercept { ok(1, "pass"); ok(0, "fail"); ... }; This function takes a codeblock as its only argument, and it has a prototype. It will execute the codeblock, intercepting any generated events in the process. It will return an array reference with all the generated event objects. All events should be subclasses of L. This is a very low-level subtest tool. This is useful for writing tools which produce subtests. This is not intended for people simply writing tests. =head2 run_subtest(...) Usage: run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) # or run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) This will run the provided codeblock with the args in C<@args>. This codeblock will be run as a subtest. A subtest is an isolated test state that is condensed into a single L event, which contains all events generated inside the subtest. =head3 ARGUMENTS: =over 4 =item $NAME The name of the subtest. =item \&CODE The code to run inside the subtest. =item $BUFFERED or \%PARAMS If this is a simple scalar then it will be treated as a boolean for the 'buffered' setting. If this is a hash reference then it will be used as a parameters hash. The param hash will be used for hub construction (with the specified keys removed). Keys that are removed and used by run_subtest: =over 4 =item 'buffered' => $bool Toggle buffered status. =item 'inherit_trace' => $bool Normally the subtest hub is pushed and the sub is allowed to generate its own root context for the hub. When this setting is turned on a root context will be created for the hub that shares the same trace as the current context. Set this to true if your tool is producing subtests without user-specified subs. =item 'no_fork' => $bool Defaults to off. Normally forking inside a subtest will actually fork the subtest, resulting in 2 final subtest events. This parameter will turn off that behavior, only the original process/thread will return a final subtest event. =back =item @ARGS Any extra arguments you want passed into the subtest code. =back =head3 BUFFERED VS UNBUFFERED (OR STREAMED) Normally all events inside and outside a subtest are sent to the formatter immediately by the hub. Sometimes it is desirable to hold off sending events within a subtest until the subtest is complete. This usually depends on the formatter being used. =over 4 =item Things not effected by this flag In both cases events are generated and stored in an array. This array is eventually used to populate the C attribute on the L event that is generated at the end of the subtest. This flag has no effect on this part, it always happens. At the end of the subtest, the final L event is sent to the formatter. =item Things that are effected by this flag The C attribute of the L event will be set to the value of this flag. This means any formatter, listener, etc which looks at the event will know if it was buffered. =item Things that are formatter dependant Events within a buffered subtest may or may not be sent to the formatter as they happen. If a formatter fails to specify then the default is to B the events as they are generated, instead the formatter can pull them from the C attribute. A formatter can specify by implementing the C method. If this method returns true then events generated inside a buffered subtest will not be sent independently of the final subtest event. =back An example of how this is used is the L formatter. For unbuffered subtests the events are rendered as they are generated. At the end of the subtest, the final subtest event is rendered, but the C attribute is ignored. For buffered subtests the opposite occurs, the events are NOT rendered as they are generated, instead the C attribute is used to render them all at once. This is useful when running subtests tests in parallel, since without it the output from subtests would be interleaved together. =head1 OTHER API EXPORTS Exports in this section are not commonly needed. These all have the 'test2_' prefix to help ensure they stand out. You should look at the L section before looking here. This section is one where "Great power comes with great responsibility". It is possible to break things badly if you are not careful with these. All exports are optional. You need to list which ones you want at import time: use Test2::API qw/test2_init_done .../; =head2 STATUS AND INITIALIZATION STATE These provide access to internal state and object instances. =over 4 =item $bool = test2_init_done() This will return true if the stack and IPC instances have already been initialized. It will return false if they have not. Init happens as late as possible. It happens as soon as a tool requests the IPC instance, the formatter, or the stack. =item $bool = test2_load_done() This will simply return the boolean value of the loaded flag. If Test2 has finished loading this will be true, otherwise false. Loading is considered complete the first time a tool requests a context. =item test2_set_is_end() =item test2_set_is_end($bool) This is used to toggle Test2's belief that the END phase has already started. With no arguments this will set it to true. With arguments it will set it to the first argument's value. This is used to prevent the use of C in END blocks which can cause segfaults. This is only necessary in some persistent environments that may have multiple END phases. =item $bool = test2_get_is_end() Check if Test2 believes it is the END phase. =item $stack = test2_stack() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item test2_ipc_disable Disable IPC. =item $bool = test2_ipc_diabled Check if IPC is disabled. =item test2_ipc_wait_enable() =item test2_ipc_wait_disable() =item $bool = test2_ipc_wait_enabled() These can be used to turn IPC waiting on and off, or check the current value of the flag. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $bool = test2_no_wait() =item test2_no_wait($bool) B: This is a confusing interface, it is better to use C, C and C. This can be used to get/set the no_wait status. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $fh = test2_stdout() =item $fh = test2_stderr() These functions return the filehandles that test output should be written to. They are primarily useful when writing a custom formatter and code that turns events into actual output (TAP, etc.) They will return a dupe of the original filehandles that formatted output can be sent to regardless of whatever state the currently running test may have left STDOUT and STDERR in. =item test2_reset_io() Re-dupe the internal filehandles returned by C and C from the current STDOUT and STDERR. You shouldn't need to do this except in very peculiar situations (for example, you're testing a new formatter and you need control over where the formatter is sending its output.) =back =head2 BEHAVIOR HOOKS These are hooks that allow you to add custom behavior to actions taken by Test2 and tools built on top of it. =over 4 =item test2_add_callback_exit(sub { ... }) This can be used to add a callback that is called after all testing is done. This is too late to add additional results, the main use of this callback is to set the exit code. test2_add_callback_exit( sub { my ($context, $exit, \$new_exit) = @_; ... } ); The C<$context> passed in will be an instance of L. The C<$exit> argument will be the original exit code before anything modified it. C<$$new_exit> is a reference to the new exit code. You may modify this to change the exit code. Please note that C<$$new_exit> may already be different from C<$exit> =item test2_add_callback_post_load(sub { ... }) Add a callback that will be called when Test2 is finished loading. This means the callback will be run once, the first time a context is obtained. If Test2 has already finished loading then the callback will be run immediately. =item test2_add_callback_context_acquire(sub { ... }) Add a callback that will be called every time someone tries to acquire a context. This will be called on EVERY call to C. It gets a single argument, a reference to the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. =item test2_add_callback_context_init(sub { ... }) Add a callback that will be called every time a new context is created. The callback will receive the newly created context as its only argument. =item test2_add_callback_context_release(sub { ... }) Add a callback that will be called every time a context is released. The callback will receive the released context as its only argument. =item test2_add_callback_pre_subtest(sub { ... }) Add a callback that will be called every time a subtest is going to be run. The callback will receive the subtest name, coderef, and any arguments. =item @list = test2_list_context_acquire_callbacks() Return all the context acquire callback references. =item @list = test2_list_context_init_callbacks() Returns all the context init callback references. =item @list = test2_list_context_release_callbacks() Returns all the context release callback references. =item @list = test2_list_exit_callbacks() Returns all the exit callback references. =item @list = test2_list_post_load_callbacks() Returns all the post load callback references. =item @list = test2_list_pre_subtest_callbacks() Returns all the pre-subtest callback references. =back =head2 IPC AND CONCURRENCY These let you access, or specify, the IPC system internals. =over 4 =item $bool = test2_has_ipc() Check if IPC is enabled. =item $ipc = test2_ipc() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item test2_ipc_add_driver($DRIVER) Add an IPC driver to the list. This will add the driver to the start of the list. =item @drivers = test2_ipc_drivers() Get the list of IPC drivers. =item $bool = test2_ipc_polling() Check if polling is enabled. =item test2_ipc_enable_polling() Turn on polling. This will cull events from other processes and threads every time a context is created. =item test2_ipc_disable_polling() Turn off IPC polling. =item test2_ipc_enable_shm() Turn on IPC SHM. Only some IPC drivers use this, and most will turn it on themselves. =item test2_ipc_set_pending($uniq_val) Tell other processes and events that an event is pending. C<$uniq_val> should be a unique value no other thread/process will generate. B After calling this C will return 1. This is intentional, and not avoidable. =item $pending = test2_ipc_get_pending() This returns -1 if there is no way to check (assume yes) This returns 0 if there are (most likely) no pending events. This returns 1 if there are (likely) pending events. Upon return it will reset, nothing else will be able to see that there were pending events. =item $timeout = test2_ipc_get_timeout() =item test2_ipc_set_timeout($timeout) Get/Set the timeout value for the IPC system. This timeout is how long the IPC system will wait for child processes and threads to finish before aborting. The default value is C<30> seconds. =back =head2 MANAGING FORMATTERS These let you access, or specify, the formatters that can/should be used. =over 4 =item $formatter = test2_formatter This will return the global formatter class. This is not an instance. By default the formatter is set to L. You can override this default using the C environment variable. Normally 'Test2::Formatter::' is prefixed to the value in the environment variable: $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter If you want to specify a full module name you use the '+' prefix: $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter =item test2_formatter_set($class_or_instance) Set the global formatter class. This can only be set once. B This will override anything specified in the 'T2_FORMATTER' environment variable. =item @formatters = test2_formatters() Get a list of all loaded formatters. =item test2_formatter_add($class_or_instance) Add a formatter to the list. Last formatter added is used at initialization. If this is called after initialization a warning will be issued. =back =head1 OTHER EXAMPLES See the C directory included in this distribution. =head1 SEE ALSO L - Detailed documentation of the context object. L - The IPC system used for threading/fork support. L - Formatters such as TAP live here. L - Events live in this namespace. L - All events eventually funnel through a hub. Custom hubs are how C and C are implemented. =head1 MAGIC This package has an END block. This END block is responsible for setting the exit code based on the test results. This end block also calls the callbacks that can be added to this package. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test/0000755000175000017500000000000013243466361015532 5ustar exodistexodistTest-Simple-1.302125/lib/Test/Tester/0000755000175000017500000000000013243466361017000 5ustar exodistexodistTest-Simple-1.302125/lib/Test/Tester/CaptureRunner.pm0000644000175000017500000000242613243466361022137 0ustar exodistexodist# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ use strict; package Test::Tester::CaptureRunner; our $VERSION = '1.302125'; use Test::Tester::Capture; require Exporter; sub new { my $pkg = shift; my $self = bless {}, $pkg; return $self; } sub run_tests { my $self = shift; my $test = shift; capture()->reset; $self->{StartLevel} = $Test::Builder::Level; &$test(); } sub get_results { my $self = shift; my @results = capture()->details; my $start = $self->{StartLevel}; foreach my $res (@results) { next if defined $res->{depth}; my $depth = $res->{_depth} - $res->{_level} - $start - 3; # print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; $res->{depth} = $depth; } return @results; } sub get_premature { return capture()->premature; } sub capture { return Test::Tester::Capture->new; } __END__ =head1 NAME Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder =head1 DESCRIPTION This stuff if needed to allow me to play with other ways of monitoring the test results. =head1 AUTHOR Copyright 2003 by Fergal Daly . =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut Test-Simple-1.302125/lib/Test/Tester/Delegate.pm0000644000175000017500000000107313243466361021051 0ustar exodistexodistuse strict; use warnings; package Test::Tester::Delegate; our $VERSION = '1.302125'; use Scalar::Util(); use vars '$AUTOLOAD'; sub new { my $pkg = shift; my $obj = shift; my $self = bless {}, $pkg; return $self; } sub AUTOLOAD { my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; return if $sub eq "DESTROY"; my $obj = $_[0]->{Object}; my $ref = $obj->can($sub); shift(@_); unshift(@_, $obj); goto &$ref; } sub can { my $this = shift; my ($sub) = @_; return $this->{Object}->can($sub) if Scalar::Util::blessed($this); return $this->SUPER::can(@_); } 1; Test-Simple-1.302125/lib/Test/Tester/Capture.pm0000644000175000017500000001067513243466361020752 0ustar exodistexodistuse strict; package Test::Tester::Capture; our $VERSION = '1.302125'; use Test::Builder; use vars qw( @ISA ); @ISA = qw( Test::Builder ); # Make Test::Tester::Capture thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads::shared; threads::shared->import; } else { *share = sub { 0 }; *lock = sub { 0 }; } } my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my $Prem_Diag = {diag => ""}; share($Curr_Test); sub new { # Test::Tester::Capgture::new used to just return __PACKAGE__ # because Test::Builder::new enforced it's singleton nature by # return __PACKAGE__. That has since changed, Test::Builder::new now # returns a blessed has and around version 0.78, Test::Builder::todo # started wanting to modify $self. To cope with this, we now return # a blessed hash. This is a short-term hack, the correct thing to do # is to detect which style of Test::Builder we're dealing with and # act appropriately. my $class = shift; return bless {}, $class; } sub ok { my($self, $test, $name) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; lock $Curr_Test; $Curr_Test++; my($pack, $file, $line) = $self->caller; my $todo = $self->todo(); my $result = {}; share($result); unless( $test ) { @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $result->{fail_diag} = (" $msg test ($file at line $line)\n"); } $result->{diag} = ""; $result->{_level} = $Test::Builder::Level; $result->{_depth} = Test::Tester::find_run_tests(); $ctx->release; return $test ? 1 : 0; } sub skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub todo_skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; my $ctx = $self->ctx; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; $result->{diag} .= join("", @msgs); $ctx->release; return 0; } sub details { return @Test_Results; } # Stub. Feel free to send me a patch to implement this. sub note { } sub explain { return Test::Builder::explain(@_); } sub premature { return $Prem_Diag->{diag}; } sub current_test { if (@_ > 1) { die "Don't try to change the test number!"; } else { return $Curr_Test; } } sub reset { $Curr_Test = 0; @Test_Results = (); $Prem_Diag = {diag => ""}; } 1; __END__ =head1 NAME Test::Tester::Capture - Help testing test modules built with Test::Builder =head1 DESCRIPTION This is a subclass of Test::Builder that overrides many of the methods so that they don't output anything. It also keeps track of it's own set of test results so that you can use Test::Builder based modules to perform tests on other Test::Builder based modules. =head1 AUTHOR Most of the code here was lifted straight from Test::Builder and then had chunks removed by Fergal Daly . =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut Test-Simple-1.302125/lib/Test/Builder/0000755000175000017500000000000013243466361017120 5ustar exodistexodistTest-Simple-1.302125/lib/Test/Builder/Tester/0000755000175000017500000000000013243466361020366 5ustar exodistexodistTest-Simple-1.302125/lib/Test/Builder/Tester/Color.pm0000644000175000017500000000171513243466361022006 0ustar exodistexodistpackage Test::Builder::Tester::Color; use strict; our $VERSION = '1.302125'; require Test::Builder::Tester; =head1 NAME Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester =head1 SYNOPSIS When running a test script perl -MTest::Builder::Tester::Color test.t =head1 DESCRIPTION Importing this module causes the subroutine color in Test::Builder::Tester to be called with a true value causing colour highlighting to be turned on in debug output. The sole purpose of this module is to enable colour highlighting from the command line. =cut sub import { Test::Builder::Tester::color(1); } =head1 AUTHOR Copyright Mark Fowler Emark@twoshortplanks.comE 2002. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS This module will have no effect unless Term::ANSIColor is installed. =head1 SEE ALSO L, L =cut 1; Test-Simple-1.302125/lib/Test/Builder/IO/0000755000175000017500000000000013243466361017427 5ustar exodistexodistTest-Simple-1.302125/lib/Test/Builder/IO/Scalar.pm0000644000175000017500000003251013243466361021173 0ustar exodistexodistpackage Test::Builder::IO::Scalar; =head1 NAME Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder =head1 DESCRIPTION This is a copy of L which ships with L to support scalar references as filehandles on Perl 5.6. Newer versions of Perl simply use C's built in support. L can not have dependencies on other modules without careful consideration, so its simply been copied into the distribution. =head1 COPYRIGHT and LICENSE This file came from the "IO-stringy" Perl5 toolkit. Copyright (c) 1996 by Eryq. All rights reserved. Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # This is copied code, I don't care. ##no critic use Carp; use strict; use vars qw($VERSION @ISA); use IO::Handle; use 5.005; ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.114"; ### Inheritance: @ISA = qw(IO::Handle); #============================== =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Return a new, unattached scalar handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [SCALARREF] I Open the scalar handle on a new scalar, pointed to by SCALARREF. If no SCALARREF is given, a "private" scalar is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $sref) = @_; ### Sanity: defined($sref) or do {my $s = ''; $sref = \$s}; (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; ### Setup: *$self->{Pos} = 0; ### seek position *$self->{SR} = $sref; ### scalar reference $self; } #------------------------------ =item opened I Is the scalar handle opened on something? =cut sub opened { *{shift()}->{SR}; } #------------------------------ =item close I Disassociate the scalar handle from its underlying scalar. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item getc I Return the next character, or undef if none remain. =cut sub getc { my $self = shift; ### Return undef right away if at EOF; else, move pos forward: return undef if $self->eof; substr(${*$self->{SR}}, *$self->{Pos}++, 1); } #------------------------------ =item getline I Return the next line, or undef on end of string. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; ### Return undef right away if at EOF: return undef if $self->eof; ### Get next line: my $sr = *$self->{SR}; my $i = *$self->{Pos}; ### Start matching at this point. ### Minimal impact implementation! ### We do the fast fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { *$self->{Pos} = length $$sr; return substr($$sr, $i); } ### Case 2: $/ is "\n": zoom zoom zoom... elsif ($/ eq "\012") { ### Seek ahead for "\n"... yes, this really is faster than regexps. my $len = length($$sr); for (; $i < $len; ++$i) { last if ord (substr ($$sr, $i, 1)) == 10; } ### Extract the line: my $line; if ($i < $len) { ### We found a "\n": $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); *$self->{Pos} = $i+1; ### Remember where we finished up. } else { ### No "\n"; slurp the remainder: $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); *$self->{Pos} = $len; } return $line; } ### Case 3: $/ is ref to int. Do fixed-size records. ### (Thanks to Dominique Quatravaux.) elsif (ref($/)) { my $len = length($$sr); my $i = ${$/} + 0; my $line = substr ($$sr, *$self->{Pos}, $i); *$self->{Pos} += $i; *$self->{Pos} = $len if (*$self->{Pos} > $len); return $line; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### This is Graham's general-purpose stuff, which might be ### a tad slower than Case 2 for typical data, because ### of the regexps. else { pos($$sr) = $i; ### If in paragraph mode, skip leading lines (and update i!): length($/) or (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); ### If we see the separator in the buffer ahead... if (length($/) ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! : $$sr =~ m,\n\n,g ### (a paragraph) ) { *$self->{Pos} = pos $$sr; return substr($$sr, $i, *$self->{Pos}-$i); } ### Else if no separator remains, just slurp the rest: else { *$self->{Pos} = length $$sr; return substr($$sr, $i); } } } #------------------------------ =item getlines I Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I Print ARGS to the underlying scalar. B this continues to always cause a seek to the end of the string, but if you perform seek()s and tell()s, it is still safer to explicitly seek-to-end before subsequent print()s. =cut sub print { my $self = shift; *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); 1; } sub _unsafe_print { my $self = shift; my $append = join('', @_) . $\; ${*$self->{SR}} .= $append; *$self->{Pos} += length($append); 1; } sub _old_print { my $self = shift; ${*$self->{SR}} .= join('', @_) . $\; *$self->{Pos} = length(${*$self->{SR}}); 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET] I Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); $n = length($read); *$self->{Pos} += $n; ($off ? substr($_[1], $off) : $_[1]) = $read; return $n; } #------------------------------ =item write BUF, NBYTES, [OFFSET] I Write some bytes to the scalar. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $off, $n); $n = length($data); $self->print($data); return $n; } #------------------------------ =item sysread BUF, LEN, [OFFSET] I Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub sysread { my $self = shift; $self->read(@_); } #------------------------------ =item syswrite BUF, NBYTES, [OFFSET] I Write some bytes to the scalar. =cut sub syswrite { my $self = shift; $self->write(@_); } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I Are we at end of file? =cut sub eof { my $self = shift; (*$self->{Pos} >= length(${*$self->{SR}})); } #------------------------------ =item seek OFFSET, WHENCE I Seek to a given position in the stream. =cut sub seek { my ($self, $pos, $whence) = @_; my $eofpos = length(${*$self->{SR}}); ### Seek: if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END else { croak "bad seek whence ($whence)" } ### Fixup: if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } return 1; } #------------------------------ =item sysseek OFFSET, WHENCE I Identical to C, I =cut sub sysseek { my $self = shift; $self->seek (@_); } #------------------------------ =item tell I Return the current position in the stream, as a numeric offset. =cut sub tell { *{shift()}->{Pos} } #------------------------------ =item use_RS [YESNO] I B Obey the current setting of $/, like IO::Handle does? Default is false in 1.x, but cold-welded true in 2.x and later. =cut sub use_RS { my ($self, $yesno) = @_; carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; } #------------------------------ =item setpos POS I Set the current position, using the opaque value returned by C. =cut sub setpos { shift->seek($_[0],0) } #------------------------------ =item getpos I Return the current position in the string, as an opaque object. =cut *getpos = \&tell; #------------------------------ =item sref I Return a reference to the underlying scalar. =cut sub sref { *{shift()}->{SR} } #------------------------------ # Tied handle methods... #------------------------------ # Conventional tiehandle interface: sub TIEHANDLE { ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) ? $_[1] : shift->new(@_)); } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub FILENO { -1 } #------------------------------------------------------------ 1; __END__ =back =cut =head1 WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for C, C, and C. Attempting to use these functions with an IO::Scalar will not work prior to 5.005_57. IO::Scalar will not have the relevant methods invoked; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via C<$^W> or C), and you see something like this... attempt to seek on unopened filehandle ...then you are probably trying to use one of these functions on an IO::Scalar with an old Perl. The remedy is to simply use the OO version; e.g.: $SH->seek(0,0); ### GOOD: will work on any 5.005 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond =head1 VERSION $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHORS =head2 Primary Maintainer David F. Skoll (F). =head2 Principal author Eryq (F). President, ZeeGee Software Inc (F). =head2 Other contributors The full set of contributors always includes the folks mentioned in L. But just the same, special thanks to the following individuals for their invaluable contributions (if I've forgotten or misspelled your name, please email me!): I for contributing C. I for suggesting C. I for finding and fixing the bug in C. I for his offset-using read() and write() implementations. I for his patches to massively improve the performance of C and add C and C. I for stringification and inheritance improvements, and sundry good ideas. I for the IO::Handle inheritance and automatic tie-ing. =head1 SEE ALSO L, which is quite similar but which was designed more-recently and with an IO::Handle-like interface in mind, so you could mix OO- and native-filehandle usage without using tied(). I as of version 2.x, these classes all work like their IO::Handle counterparts, so we have comparable functionality to IO::String. =cut Test-Simple-1.302125/lib/Test/Builder/Formatter.pm0000644000175000017500000000372013243466361021423 0ustar exodistexodistpackage Test::Builder::Formatter; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } use Test2::Util::HashBase qw/no_header no_diag/; BEGIN { *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); my $todo = OUT_ERR() + 1; *OUT_TODO = sub() { $todo }; } sub init { my $self = shift; $self->SUPER::init(@_); $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; } sub plan_tap { my ($self, $f) = @_; return if $self->{+NO_HEADER}; return $self->SUPER::plan_tap($f); } sub debug_tap { my ($self, $f, $num) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::debug_tap($f, $num); $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub info_tap { my ($self, $f) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::info_tap($f); $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub redirect { my ($self, $out) = @_; $_->[0] = OUT_TODO for @$out; } sub no_subtest_space { 1 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test::Builder; # Loads Test::Builder::Formatter for you =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test/Builder/TodoDiag.pm0000644000175000017500000000207113243466361021150 0ustar exodistexodistpackage Test::Builder::TodoDiag; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } sub diagnostics { 0 } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); $out->{info}->[0]->{debug} = 0; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag =head1 DESCRIPTION This is used to encapsulate diag messages created inside TODO. =head1 SYNOPSIS You do not need to use this directly. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/Test/Builder/Tester.pm0000644000175000017500000004316313243466361020733 0ustar exodistexodistpackage Test::Builder::Tester; use strict; our $VERSION = '1.302125'; use Test::Builder; use Symbol; use Carp; =head1 NAME Test::Builder::Tester - test testsuites that have been built with Test::Builder =head1 SYNOPSIS use Test::Builder::Tester tests => 1; use Test::More; test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =head1 DESCRIPTION A module that helps you test testing modules that are built with L. The testing system is designed to be used by performing a three step process for each test you wish to test. This process starts with using C and C in advance to declare what the testsuite you are testing will output with L to stdout and stderr. You then can run the test(s) from your test suite that call L. At this point the output of L is safely captured by L rather than being interpreted as real test output. The final stage is to call C that will simply compare what you predeclared to what L actually outputted, and report the results back with a "ok" or "not ok" (with debugging) to the normal output. =cut #### # set up testing #### my $t = Test::Builder->new; ### # make us an exporter ### use Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); sub import { my $class = shift; my(@plan) = @_; my $caller = caller; $t->exported_to($caller); $t->plan(@plan); my @imports = (); foreach my $idx ( 0 .. $#plan ) { if( $plan[$idx] eq 'import' ) { @imports = @{ $plan[ $idx + 1 ] }; last; } } __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); } ### # set up file handles ### # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; #### # exported functions #### # for remembering that we're testing and where we're testing at my $testing = 0; my $testing_num; my $original_is_passing; # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $original_formatter; my $original_harness_env; # function that starts testing and redirects the filehandles for now sub _start_testing { # Hack for things that conditioned on Test-Stream being loaded $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top); $original_formatter = $hub->format; unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { my $fmt = Test::Builder::Formatter->new; $hub->format($fmt); } # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($output_handle); # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing = 1; $testing_num = $t->current_test; $t->current_test(0); $original_is_passing = $t->is_passing; $t->is_passing(1); # look, we shouldn't do the ending stuff $t->no_ending(1); } =head2 Functions These are the six methods that are exported as default. =over 4 =item test_out =item test_err Procedures for predeclaring the output that your test suite is expected to produce until C is called. These procedures automatically assume that each line terminates with "\n". So test_out("ok 1","ok 2"); is the same as test_out("ok 1\nok 2"); which is even the same as test_out("ok 1"); test_out("ok 2"); Once C or C (or C or C) have been called, all further output from L will be captured by L. This means that you will not be able perform further tests to the normal output in the normal way until you call C (well, unless you manually meddle with the output filehandles) =cut sub test_out { # do we need to do any setup? _start_testing() unless $testing; $out->expect(@_); } sub test_err { # do we need to do any setup? _start_testing() unless $testing; $err->expect(@_); } =item test_fail Because the standard failure message that L produces whenever a test fails will be a common occurrence in your test error output, and because it has changed between Test::Builder versions, rather than forcing you to call C with the string all the time like so test_err("# Failed test ($0 at line ".line_num(+1).")"); C exists as a convenience function that can be called instead. It takes one argument, the offset from the current line that the line that causes the fail is on. test_fail(+1); This means that the example in the synopsis could be rewritten more simply as: test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =cut sub test_fail { # do we need to do any setup? _start_testing() unless $testing; # work out what line we should be on my( $package, $filename, $line ) = caller; $line = $line + ( shift() || 0 ); # prevent warnings # expect that on stderr $err->expect("# Failed test ($filename at line $line)"); } =item test_diag As most of the remaining expected output to the error stream will be created by L's C function, L provides a convenience function C that you can use instead of C. The C function prepends comment hashes and spacing to the start and newlines to the end of the expected output passed to it and adds it to the list of expected error output. So, instead of writing test_err("# Couldn't open file"); you can write test_diag("Couldn't open file"); Remember that L's diag function will not add newlines to the end of output and test_diag will. So to check Test::Builder->new->diag("foo\n","bar\n"); You would do test_diag("foo","bar") without the newlines. =cut sub test_diag { # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; $err->expect( map { "# $_" } @_ ); } =item test_test Actually performs the output check testing the tests, comparing the data (with C) that we have captured from L against what was declared with C and C. This takes name/value pairs that effect how the test is run. =over =item title (synonym 'name', 'label') The name of the test that will be displayed after the C or C. =item skip_out Setting this to a true value will cause the test to ignore if the output sent by the test to the output stream does not match that declared with C. =item skip_err Setting this to a true value will cause the test to ignore if the output sent by the test to the error stream does not match that declared with C. =back As a convenience, if only one argument is passed then this argument is assumed to be the name of the test (as in the above examples.) Once C has been run test output will be redirected back to the original filehandles that L was connected to (probably STDOUT and STDERR,) meaning any further tests you run will function normally and cause success/errors for L. =cut sub test_test { # END the hack delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; # decode the arguments as described in the pod my $mess; my %args; if( @_ == 1 ) { $mess = shift } else { %args = @_; $mess = $args{name} if exists( $args{name} ); $mess = $args{title} if exists( $args{title} ); $mess = $args{label} if exists( $args{label} ); } # er, are we testing? croak "Not testing. You must declare output with a test function first." unless $testing; my $hub = $t->{Hub} || Test2::API::test2_stack->top; $hub->format($original_formatter); # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); # restore the test no, etc, back to the original point $t->current_test($testing_num); $testing = 0; $t->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; # check the output we've stashed unless( $t->ok( ( $args{skip_out} || $out->check ) && ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this # test failed local $_; $t->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; $t->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } =item line_num A utility function that returns the line number that the function was called on. You can pass it an offset which will be added to the result. This is very useful for working out the correct text of diagnostic functions that contain line numbers. Essentially this is the same as the C<__LINE__> macro, but the C idiom is arguably nicer. =cut sub line_num { my( $package, $filename, $line ) = caller; return $line + ( shift() || 0 ); # prevent warnings } =back In addition to the six exported functions there exists one function that can only be accessed with a fully qualified function call. =over 4 =item color When C is called and the output that your tests generate does not match that which you declared, C will print out debug information showing the two conflicting versions. As this output itself is debug information it can be confusing which part of the output is from C and which was the original output from your original tests. Also, it may be hard to spot things like extraneous whitespace at the end of lines that may cause your test to fail even though the output looks similar. To assist you C can colour the background of the debug information to disambiguate the different types of output. The debug output will have its background coloured green and red. The green part represents the text which is the same between the executed and actual output, the red shows which part differs. The C function determines if colouring should occur or not. Passing it a true or false value will enable or disable colouring respectively, and the function called with no argument will return the current setting. To enable colouring from the command line, you can use the L module like so: perl -Mlib=Text::Builder::Tester::Color test.t Or by including the L module directly in the PERL5LIB. =cut my $color; sub color { $color = shift if @_; $color; } =back =head1 BUGS Test::Builder::Tester does not handle plans well. It has never done anything special with plans. This means that plans from outside Test::Builder::Tester will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester will effect overall testing. At this point there are no plans to fix this bug as people have come to depend on it, and Test::Builder::Tester is now discouraged in favor of C. See L Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. The color function doesn't work unless L is compatible with your terminal. Additionally, L must be installed on windows platforms for color output. Bugs (and requests for new features) can be reported to the author though GitHub: L =head1 AUTHOR Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. Some code taken from L and L, written by Michael G Schwern Eschwern@pobox.comE. Hence, those parts Copyright Micheal G Schwern 2001. Used and distributed with permission. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 NOTES Thanks to Richard Clamp Erichardc@unixbeard.netE for letting me use his testing system to try this module out on. =head1 SEE ALSO L, L, L. =cut 1; #################################################################### # Helper class that is used to remember expected and received data package Test::Builder::Tester::Tie; ## # add line(s) to be expected sub expect { my $self = shift; my @checks = @_; foreach my $check (@checks) { $check = $self->_account_for_subtest($check); $check = $self->_translate_Failed_check($check); push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; } } sub _account_for_subtest { my( $self, $check ) = @_; my $hub = $t->{Stack}->top; my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; return ref($check) ? $check : (' ' x $nesting) . $check; } sub _translate_Failed_check { my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; } return $check; } ## # return true iff the expected data matches the got data sub check { my $self = shift; # turn off warnings as these might be undef local $^W = 0; my @checks = @{ $self->{wanted} }; my $got = $self->{got}; foreach my $check (@checks) { $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); return 0 unless $got =~ s/^$check//; } return length $got == 0; } ## # a complaint message about the inputs not matching (to be # used for debugging messages) sub complaint { my $self = shift; my $type = $self->type; my $got = $self->got; my $wanted = join '', @{ $self->wanted }; # are we running in colour mode? if(Test::Builder::Tester::color) { # get color eval { require Term::ANSIColor }; unless($@) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms # colours my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); my $reset = Term::ANSIColor::color("reset"); # work out where the two strings start to differ my $char = 0; $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); # get the start string and the two end strings my $start = $green . substr( $wanted, 0, $char ); my $gotend = $red . substr( $got, $char ) . $reset; my $wantedend = $red . substr( $wanted, $char ) . $reset; # make the start turn green on and off $start =~ s/\n/$reset\n$green/g; # make the ends turn red on and off $gotend =~ s/\n/$reset\n$red/g; $wantedend =~ s/\n/$reset\n$red/g; # rebuild the strings $got = $start . $gotend; $wanted = $start . $wantedend; } } my @got = split "\n", $got; my @wanted = split "\n", $wanted; $got = ""; $wanted = ""; while (@got || @wanted) { my $g = shift @got || ""; my $w = shift @wanted || ""; if ($g ne $w) { if($g =~ s/(\s+)$/ |> /g) { $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } if($w =~ s/(\s+)$/ |> /g) { $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } $g = "> $g"; $w = "> $w"; } else { $g = " $g"; $w = " $w"; } $got = $got ? "$got\n$g" : $g; $wanted = $wanted ? "$wanted\n$w" : $w; } return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data sub reset { my $self = shift; %$self = ( type => $self->{type}, got => '', wanted => [], ); } sub got { my $self = shift; return $self->{got}; } sub wanted { my $self = shift; return $self->{wanted}; } sub type { my $self = shift; return $self->{type}; } ### # tie interface ### sub PRINT { my $self = shift; $self->{got} .= join '', @_; } sub TIEHANDLE { my( $class, $type ) = @_; my $self = bless { type => $type }, $class; $self->reset; return $self; } sub READ { } sub READLINE { } sub GETC { } sub FILENO { } 1; Test-Simple-1.302125/lib/Test/Builder/Module.pm0000644000175000017500000000752713243466361020716 0ustar exodistexodistpackage Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '1.302125'; =head1 NAME Test::Builder::Module - Base class for test modules =head1 SYNOPSIS # Emulates Test::Simple package Your::Module; my $CLASS = __PACKAGE__; use parent 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { my $tb = $CLASS->builder; return $tb->ok(@_); } 1; =head1 DESCRIPTION This is a superclass for L-based modules. It provides a handful of common functionality and a method of getting at the underlying L object. =head2 Importing Test::Builder::Module is a subclass of L which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. A few methods are provided to do the C<< use Your::Module tests => 23 >> part for you. =head3 import Test::Builder::Module provides an C method which acts in the same basic way as L's, setting the plan and controlling exporting of functions and variables. This allows your module to set the plan independent of L. All arguments passed to C are passed onto C<< Your::Module->builder->plan() >> with the exception of C<< import =>[qw(things to import)] >>. use Your::Module import => [qw(this that)], tests => 23; says to import the functions C and C as well as set the plan to be 23 tests. C also sets the C attribute of your builder to be the caller of the C function. Additional behaviors can be added to your C method by overriding C. =cut sub import { my($class) = shift; Test2::API::test2_load() unless Test2::API::test2_in_preload(); # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; $class->Exporter::import(@imports); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } =head3 import_extra Your::Module->import_extra(\@import_args); C is called by C. It provides an opportunity for you to add behaviors to your module based on its import list. Any extra arguments which shouldn't be passed on to C should be stripped off by this method. See L for an example of its use. B This mechanism is I as it feels like a bit of an ugly hack in its current form. =cut sub import_extra { } =head2 Builder Test::Builder::Module provides some methods of getting at the underlying Test::Builder object. =head3 builder my $builder = Your::Class->builder; This method returns the L object associated with Your::Class. It is not a constructor so you can call it as often as you like. This is the preferred way to get the L object. You should I get it via C<< Test::Builder->new >> as was previously recommended. The object returned by C may change at runtime so you should call C inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; return $builder->ok(@_); } =cut sub builder { return Test::Builder->new; } 1; Test-Simple-1.302125/lib/Test/Tutorial.pod0000644000175000017500000004562213243466361020052 0ustar exodistexodist=head1 NAME Test::Tutorial - A tutorial about writing really basic tests =head1 DESCRIPTION I I<*sob*> I Is this you? Is writing tests right up there with writing documentation and having your fingernails pulled out? Did you open up a test and read ######## We start with some black magic and decide that's quite enough for you? It's ok. That's all gone now. We've done all the black magic for you. And here are the tricks... =head2 Nuts and bolts of testing. Here's the most basic test program. #!/usr/bin/perl -w print "1..1\n"; print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; Because 1 + 1 is 2, it prints: 1..1 ok 1 What this says is: C<1..1> "I'm going to run one test." [1] C "The first test passed". And that's about all magic there is to testing. Your basic unit of testing is the I. For each thing you test, an C is printed. Simple. L interprets your test results to determine if you succeeded or failed (more on that later). Writing all these print statements rapidly gets tedious. Fortunately, there's L. It has one function, C. #!/usr/bin/perl -w use Test::Simple tests => 1; ok( 1 + 1 == 2 ); That does the same thing as the previous code. C is the backbone of Perl testing, and we'll be using it instead of roll-your-own from here on. If C gets a true value, the test passes. False, it fails. #!/usr/bin/perl -w use Test::Simple tests => 2; ok( 1 + 1 == 2 ); ok( 2 + 2 == 5 ); From that comes: 1..2 ok 1 not ok 2 # Failed test (test.pl at line 5) # Looks like you failed 1 tests of 2. C<1..2> "I'm going to run two tests." This number is a I. It helps to ensure your test program ran all the way through and didn't die or skip some tests. C "The first test passed." C "The second test failed". Test::Simple helpfully prints out some extra commentary about your tests. It's not scary. Come, hold my hand. We're going to give an example of testing a module. For our example, we'll be testing a date library, L. It's on CPAN, so download a copy and follow along. [2] =head2 Where to start? This is the hardest part of testing, where do you start? People often get overwhelmed at the apparent enormity of the task of testing a whole module. The best place to start is at the beginning. L is an object-oriented module, and that means you start by making an object. Test C. #!/usr/bin/perl -w # assume these two lines are in all subsequent examples use strict; use warnings; use Test::Simple tests => 2; use Date::ICal; my $ical = Date::ICal->new; # create an object ok( defined $ical ); # check that we got something ok( $ical->isa('Date::ICal') ); # and it's the right class Run that and you should get: 1..2 ok 1 ok 2 Congratulations! You've written your first useful test. =head2 Names That output isn't terribly descriptive, is it? When you have two tests you can figure out which one is #2, but what if you have 102 tests? Each test can be given a little descriptive name as the second argument to C. use Test::Simple tests => 2; ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); Now you'll see: 1..2 ok 1 - new() returned something ok 2 - and it's the right class =head2 Test the manual The simplest way to build up a decent testing suite is to just test what the manual says it does. [3] Let's pull something out of the L and test that all its bits work. #!/usr/bin/perl -w use Test::Simple tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); ok( $ical->sec == 47, ' sec()' ); ok( $ical->min == 12, ' min()' ); ok( $ical->hour == 16, ' hour()' ); ok( $ical->day == 17, ' day()' ); ok( $ical->month == 10, ' month()' ); ok( $ical->year == 1964, ' year()' ); Run that and you get: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Whoops, a failure! [4] L helpfully lets us know on what line the failure occurred, but not much else. We were supposed to get 17, but we didn't. What did we get?? Dunno. You could re-run the test in the debugger or throw in some print statements to find out. Instead, switch from L to L. L does everything L does, and more! In fact, L does things I the way L does. You can literally swap L out and put L in its place. That's just what we're going to do. L does more than L. The most important difference at this point is it provides more informative ways to say "ok". Although you can write almost any test with a generic C, it can't tell you what went wrong. The C function lets us declare that something is supposed to be the same as something else: use Test::More tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->sec, 47, ' sec()' ); is( $ical->min, 12, ' min()' ); is( $ical->hour, 16, ' hour()' ); is( $ical->day, 17, ' day()' ); is( $ical->month, 10, ' month()' ); is( $ical->year, 1964, ' year()' ); "Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C in place, you get more information: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) # got: '16' # expected: '17' ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Aha. C<< $ical->day >> returned 16, but we expected 17. A quick check shows that the code is working fine, we made a mistake when writing the tests. Change it to: is( $ical->day, 16, ' day()' ); ... and everything works. Any time you're doing a "this equals that" sort of test, use C. It even works on arrays. The test is always in scalar context, so you can test how many elements are in an array this way. [5] is( @foo, 5, 'foo has 5 elements' ); =head2 Sometimes the tests are wrong This brings up a very important lesson. Code has bugs. Tests are code. Ergo, tests have bugs. A failing test could mean a bug in the code, but don't discount the possibility that the test is wrong. On the flip side, don't be tempted to prematurely declare a test incorrect just because you're having trouble finding the bug. Invalidating a test isn't something to be taken lightly, and don't use it as a cop out to avoid work. =head2 Testing lots of values We're going to be wanting to test a lot of dates here, trying to trick the code with lots of different edge cases. Does it work before 1970? After 2038? Before 1904? Do years after 10,000 give it trouble? Does it get leap years right? We could keep repeating the code above, or we could set up a little try/expect loop. use Test::More tests => 32; use Date::ICal; my %ICal_Dates = ( # An ICal string And the year, month, day # hour, minute and second we expect. '19971024T120000' => # from the docs. [ 1997, 10, 24, 12, 0, 0 ], '20390123T232832' => # after the Unix epoch [ 2039, 1, 23, 23, 28, 32 ], '19671225T000000' => # before the Unix epoch [ 1967, 12, 25, 0, 0, 0 ], '18990505T232323' => # before the MacOS epoch [ 1899, 5, 5, 23, 23, 23 ], ); while( my($ical_str, $expect) = each %ICal_Dates ) { my $ical = Date::ICal->new( ical => $ical_str ); ok( defined $ical, "new(ical => '$ical_str')" ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->year, $expect->[0], ' year()' ); is( $ical->month, $expect->[1], ' month()' ); is( $ical->day, $expect->[2], ' day()' ); is( $ical->hour, $expect->[3], ' hour()' ); is( $ical->min, $expect->[4], ' min()' ); is( $ical->sec, $expect->[5], ' sec()' ); } Now we can test bunches of dates by just adding them to C<%ICal_Dates>. Now that it's less work to test with more dates, you'll be inclined to just throw more in as you think of them. Only problem is, every time we add to that we have to keep adjusting the C<< use Test::More tests => ## >> line. That can rapidly get annoying. There are ways to make this work better. First, we can calculate the plan dynamically using the C function. use Test::More; use Date::ICal; my %ICal_Dates = ( ...same as before... ); # For each key in the hash we're running 8 tests. plan tests => keys(%ICal_Dates) * 8; ...and then your tests... To be even more flexible, use C. This means we're just running some tests, don't know how many. [6] use Test::More; # instead of tests => 32 ... # tests here done_testing(); # reached the end safely If you don't specify a plan, L expects to see C before your program exits. It will warn you if you forget it. You can give C an optional number of tests you expected to run, and if the number ran differs, L will give you another kind of warning. =head2 Informative names Take a look at the line: ok( defined $ical, "new(ical => '$ical_str')" ); We've added more detail about what we're testing and the ICal string itself we're trying out to the name. So you get results like: ok 25 - new(ical => '19971024T120000') ok 26 - and it's the right class ok 27 - year() ok 28 - month() ok 29 - day() ok 30 - hour() ok 31 - min() ok 32 - sec() If something in there fails, you'll know which one it was and that will make tracking down the problem easier. Try to put a bit of debugging information into the test names. Describe what the tests test, to make debugging a failed test easier for you or for the next person who runs your test. =head2 Skipping tests Poking around in the existing L tests, I found this in F [7] #!/usr/bin/perl -w use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); # XXX This will only work on unix systems. is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); The beginning of the epoch is different on most non-Unix operating systems [8]. Even though Perl smooths out the differences for the most part, certain ports do it differently. MacPerl is one off the top of my head. [9] Rather than putting a comment in the test and hoping someone will read the test while debugging the failure, we can explicitly say it's never going to work and skip the test. use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); SKIP: { skip('epoch to ICal not working on Mac OS', 6) if $^O eq 'MacOS'; is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); } A little bit of magic happens here. When running on anything but MacOS, all the tests run normally. But when on MacOS, C causes the entire contents of the SKIP block to be jumped over. It never runs. Instead, C prints special output that tells L that the tests have been skipped. 1..7 ok 1 - Epoch time of 0 ok 2 # skip epoch to ICal not working on MacOS ok 3 # skip epoch to ICal not working on MacOS ok 4 # skip epoch to ICal not working on MacOS ok 5 # skip epoch to ICal not working on MacOS ok 6 # skip epoch to ICal not working on MacOS ok 7 # skip epoch to ICal not working on MacOS This means your tests won't fail on MacOS. This means fewer emails from MacPerl users telling you about failing tests that you know will never work. You've got to be careful with skip tests. These are for tests which don't work and I. It is not for skipping genuine bugs (we'll get to that in a moment). The tests are wholly and completely skipped. [10] This will work. SKIP: { skip("I don't wanna die!"); die, die, die, die, die; } =head2 Todo tests While thumbing through the L man page, I came across this: ical $ical_string = $ical->ical; Retrieves, or sets, the date on the object, using any valid ICal date/time string. "Retrieves or sets". Hmmm. I didn't see a test for using C to set the date in the Date::ICal test suite. So I wrote one: use Test::More tests => 1; use Date::ICal; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); Run that. I saw: 1..1 not ok 1 - Setting via ical() # Failed test (- at line 6) # got: '20010814T233649Z' # expected: '20201231Z' # Looks like you failed 1 tests of 1. Whoops! Looks like it's unimplemented. Assume you don't have the time to fix this. [11] Normally, you'd just comment out the test and put a note in a todo list somewhere. Instead, explicitly state "this test will fail" by wrapping it in a C block: use Test::More tests => 1; TODO: { local $TODO = 'ical($ical) not yet implemented'; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); } Now when you run, it's a little different: 1..1 not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented # got: '20010822T201551Z' # expected: '20201231Z' L doesn't say "Looks like you failed 1 tests of 1". That '# TODO' tells L "this is supposed to fail" and it treats a failure as a successful test. You can write tests even before you've fixed the underlying code. If a TODO test passes, L will report it "UNEXPECTEDLY SUCCEEDED". When that happens, remove the TODO block with C and turn it into a real test. =head2 Testing with taint mode. Taint mode is a funny thing. It's the globalest of all global features. Once you turn it on, it affects I code in your program and I modules used (and all the modules they use). If a single piece of code isn't taint clean, the whole thing explodes. With that in mind, it's very important to ensure your module works under taint mode. It's very simple to have your tests run under taint mode. Just throw a C<-T> into the C<#!> line. L will read the switches in C<#!> and use them to run your tests. #!/usr/bin/perl -Tw ...test normally here... When you say C it will run with taint mode on. =head1 FOOTNOTES =over 4 =item 1 The first number doesn't really mean anything, but it has to be 1. It's the second number that's important. =item 2 For those following along at home, I'm using version 1.31. It has some bugs, which is good -- we'll uncover them with our tests. =item 3 You can actually take this one step further and test the manual itself. Have a look at L (formerly L). =item 4 Yes, there's a mistake in the test suite. What! Me, contrived? =item 5 We'll get to testing the contents of lists later. =item 6 But what happens if your test program dies halfway through?! Since we didn't say how many tests we're going to run, how can we know it failed? No problem, L employs some magic to catch that death and turn the test into a failure, even if every test passed up to that point. =item 7 I cleaned it up a little. =item 8 Most Operating Systems record time as the number of seconds since a certain date. This date is the beginning of the epoch. Unix's starts at midnight January 1st, 1970 GMT. =item 9 MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a problem. =item 10 As long as the code inside the SKIP block at least compiles. Please don't ask how. No, it's not a filter. =item 11 Do NOT be tempted to use TODO tests as a way to avoid fixing simple bugs! =back =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE and the perl-qa dancers! =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This documentation is free; you can redistribute it and/or modify it under the same terms as Perl itself. Irrespective of its distribution, all code examples in these files are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. =cut Test-Simple-1.302125/lib/Test/Builder.pm0000644000175000017500000017402713243466361017471 0ustar exodistexodistpackage Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '1.302125'; BEGIN { if( $] < 5.008 ) { require Test::Builder::IO::Scalar; } } use Scalar::Util qw/blessed reftype weaken/; use Test2::Util qw/USE_THREADS try get_tid/; use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { warn "Test::Builder was loaded after Test2 initialization, this is not recommended." if Test2::API::test2_init_done() || Test2::API::test2_load_done(); if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) { require Test2::IPC; require Test2::IPC::Driver::Files; Test2::IPC::Driver::Files->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_no_wait(1); Test2::API::test2_ipc_enable_shm(); } } use Test2::Event::Subtest; use Test2::Hub::Subtest; use Test::Builder::Formatter; use Test::Builder::TodoDiag; our $Level = 1; our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; sub _add_ts_hooks { my $self = shift; my $hub = $self->{Stack}->top; # Take a reference to the hash key, we do this to avoid closing over $self # which is the singleton. We use a reference because the value could change # in rare cases. my $epkgr = \$self->{Exported_To}; #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); $hub->pre_filter(sub { my ($active_hub, $e) = @_; my $epkg = $$epkgr; my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; no strict 'refs'; no warnings 'once'; my $todo; $todo = ${"$cpkg\::TODO"} if $cpkg; $todo = ${"$epkg\::TODO"} if $epkg && !$todo; return $e unless $todo; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; if ($active_hub == $hub) { $e->set_todo($todo) if $e->can('set_todo'); $e->add_amnesty({tag => 'TODO', details => $todo}); } else { $e->add_amnesty({tag => 'TODO', details => $todo, inherited => 1}); } # Set todo on ok's if ($e->isa('Test2::Event::Ok')) { $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $todo; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1); } { no warnings; INIT { use warnings; Test2::API::test2_load() unless Test2::API::test2_in_preload(); } } sub new { my($class) = shift; unless($Test) { $Test = $class->create(singleton => 1); Test2::API::test2_add_callback_post_load( sub { $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; $Test->reset(singleton => 1); $Test->_add_ts_hooks; } ); # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So # we only want the level to change if $Level != 1. # TB->ctx compensates for this later. Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc(); } return $Test; } sub create { my $class = shift; my %params = @_; my $self = bless {}, $class; if ($params{singleton}) { $self->{Stack} = Test2::API::test2_stack(); } else { $self->{Stack} = Test2::API::Stack->new; $self->{Stack}->new_hub( formatter => Test::Builder::Formatter->new, ipc => Test2::API::test2_ipc(), ); $self->reset(%params); $self->_add_ts_hooks; } return $self; } sub ctx { my $self = shift; context( # 1 for our frame, another for the -1 off of $Level in our hook at the top. level => 2, fudge => 1, stack => $self->{Stack}, hub => $self->{Hub}, wrapped => 1, @_ ); } sub parent { my $self = shift; my $ctx = $self->ctx; my $chub = $self->{Hub} || $ctx->hub; $ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); my $parent = $meta->{parent}; return undef unless $parent; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $parent, }, blessed($self); } sub child { my( $self, $name ) = @_; $name ||= "Child of " . $self->name; my $ctx = $self->ctx; my $parent = $ctx->hub; my $pmeta = $parent->meta(__PACKAGE__, {}); $self->croak("You already have a child named ($pmeta->{child}) running") if $pmeta->{child}; $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); my $subevents = []; my $hub = $ctx->stack->new_hub( class => 'Test2::Hub::Subtest', ); $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; return $e; }, inherit => 1) if $orig_TODO; $hub->listen(sub { push @$subevents => $_[1] }); $hub->set_nested( $parent->nested + 1 ); my $meta = $hub->meta(__PACKAGE__, {}); $meta->{Name} = $name; $meta->{TODO} = $orig_TODO; $meta->{TODO_PKG} = $ctx->trace->package; $meta->{parent} = $parent; $meta->{Test_Results} = []; $meta->{subevents} = $subevents; $meta->{subtest_id} = $hub->id; $meta->{subtest_buffered} = $parent->format ? 0 : 1; $self->_add_ts_hooks; $ctx->release; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); } sub finalize { my $self = shift; my $ok = 1; ($ok) = @_ if @_; my $st_ctx = $self->ctx; my $chub = $self->{Hub} || return $st_ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); if ($meta->{child}) { $self->croak("Can't call finalize() with child ($meta->{child}) active"); } local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->{Stack}->pop($chub); $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); my $parent = $self->parent; my $ctx = $parent->ctx; my $trace = $ctx->trace; delete $ctx->hub->meta(__PACKAGE__, {})->{child}; $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) if $ok && $chub->count && !$chub->no_ending && !$chub->ended; my $plan = $chub->plan || 0; my $count = $chub->count; my $failed = $chub->failed; my $passed = $chub->is_passing; my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; if ($count && $num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $st_ctx->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $st_ctx->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $st_ctx->diag(<<"FAIL"); All assertions inside the subtest passed, but errors were encountered. FAIL } $st_ctx->release; unless ($chub->bailed_out) { my $plan = $chub->plan; if ( $plan && $plan eq 'SKIP' ) { $parent->skip($chub->skip_reason, $meta->{Name}); } elsif ( !$chub->count ) { $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { $parent->{subevents} = $meta->{subevents}; $parent->{subtest_id} = $meta->{subtest_id}; $parent->{subtest_buffered} = $meta->{subtest_buffered}; $parent->ok( $chub->is_passing, $meta->{Name} ); } } $ctx->release; return $chub->is_passing; } sub subtest { my $self = shift; my ($name, $code, @args) = @_; my $ctx = $self->ctx; $ctx->throw("subtest()'s second argument must be a code ref") unless $code && reftype($code) eq 'CODE'; $name ||= "Child of " . $self->name; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $ctx->note("Subtest: $name"); my $child = $self->child($name); my $start_pid = $$; my $st_ctx; my ($ok, $err, $finished, $child_error); T2_SUBTEST_WRAPPER: { my $ctx = $self->ctx; $st_ctx = $ctx->snapshot; $ctx->release; $ok = eval { local $Level = 1; $code->(@args); 1 }; ($err, $child_error) = ($@, $?); # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } my $trace = $ctx->trace; if (!$finished) { if(my $bailed = $st_ctx->hub->bailed_out) { my $chub = $child->{Hub}; $self->{Stack}->pop($chub); $ctx->bail($bailed->reason); } my $code = $st_ctx->hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } my $st_hub = $st_ctx->hub; my $plan = $st_hub->plan; my $count = $st_hub->count; if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { $st_ctx->plan(0) unless defined $plan; $st_ctx->diag('No tests run!'); } $child->finalize($st_ctx->trace); $ctx->release; die $err unless $ok; $? = $child_error if defined $child_error; return $st_hub->is_passing; } sub name { my $self = shift; my $ctx = $self->ctx; release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; } sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my ($self, %params) = @_; Test2::API::test2_set_is_end(0); # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 unless $params{singleton}; $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->release; unless ($params{singleton}) { $hub->reset_state(); $hub->_tb_reset(); } $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); %$meta = ( Name => $0, Ending => 0, Done_Testing => undef, Skip_All => 0, Test_Results => [], parent => $meta->{parent}, ); $self->{Exported_To} = undef unless $params{singleton}; $self->{Orig_Handles} ||= do { my $format = $ctx->hub->format; my $out; if ($format && $format->isa('Test2::Formatter::TAP')) { $out = $format->handles; } $out ? [@$out] : []; }; $self->use_numbers(1); $self->no_header(0) unless $params{singleton}; $self->no_ending(0) unless $params{singleton}; $self->reset_outputs; $ctx->release; return; } my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->throw("You tried to plan twice") if $hub->plan; local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $ctx->throw("plan() doesn't understand @args"); } release $ctx, 1; } sub _plan_tests { my($self, $arg) = @_; my $ctx = $self->ctx; if($arg) { local $Level = $Level + 1; $self->expected_tests($arg); } elsif( !defined $arg ) { $ctx->throw("Got an undefined number of tests"); } else { $ctx->throw("You said to run 0 tests"); } $ctx->release; } sub expected_tests { my $self = shift; my($max) = @_; my $ctx = $self->ctx; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $ctx->plan($max); } my $hub = $ctx->hub; $ctx->release; my $plan = $hub->plan; return 0 unless $plan; return 0 if $plan =~ m/\D/; return $plan; } sub no_plan { my($self, $arg) = @_; my $ctx = $self->ctx; if (defined $ctx->hub->plan) { warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; $ctx->release; return; } $ctx->alert("no_plan takes no arguments") if $arg; $ctx->hub->plan('NO PLAN'); release $ctx, 1; } sub done_testing { my($self, $num_tests) = @_; my $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); if ($meta->{Done_Testing}) { my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; local $ctx->hub->{ended}; # OMG This is awful. $self->ok(0, "done_testing() was already called at $file line $line"); $ctx->release; return; } $meta->{Done_Testing} = [$ctx->trace->call]; my $plan = $ctx->hub->plan; my $count = $ctx->hub->count; # If done_testing() specified the number of tests, shut off no_plan if( defined $num_tests ) { $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; } elsif ($count && defined $num_tests && $count != $num_tests) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); } else { $num_tests = $self->current_test; } if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; $ctx->hub->finalize($ctx->trace, 1); release $ctx, 1; } sub has_plan { my $self = shift; my $ctx = $self->ctx; my $plan = $ctx->hub->plan; $ctx->release; return( $plan ) if $plan && $plan !~ m/\D/; return('no_plan') if $plan && $plan eq 'NO PLAN'; return(undef); } sub skip_all { my( $self, $reason ) = @_; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; # Work around old perl bug if ($] < 5.020000) { my $begin = 0; my $level = 0; while (my @call = caller($level++)) { last unless @call && $call[0]; next unless $call[3] =~ m/::BEGIN$/; $begin++; last; } # HACK! die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; } $ctx->plan(0, SKIP => $reason); } sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } sub ok { my( $self, $test, $name ) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; # In case $name is a string overloaded object, force it to stringify. no warnings qw/uninitialized numeric/; $name = "$name" if defined $name; # Profiling showed that the regex here was a huge time waster, doing the # numeric addition first cuts our profile time from ~300ms to ~50ms $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR use warnings qw/uninitialized numeric/; my $trace = $ctx->{trace}; my $hub = $ctx->{hub}; my $result = { ok => $test, actual_ok => $test, reason => '', type => '', (name => defined($name) ? $name : ''), }; $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; my $orig_name = $name; my @attrs; my $subevents = delete $self->{subevents}; my $subtest_id = delete $self->{subtest_id}; my $subtest_buffered = delete $self->{subtest_buffered}; my $epkg = 'Test2::Event::Ok'; if ($subevents) { $epkg = 'Test2::Event::Subtest'; push @attrs => (subevents => $subevents, subtest_id => $subtest_id, buffered => $subtest_buffered); } my $e = bless { trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), pass => $test, name => $name, _meta => {'Test::Builder' => $result}, effective_pass => $test, @attrs, }, $epkg; $hub->send($e); $self->_ok_debug($trace, $orig_name) unless($test); $ctx->release; return $test; } sub _ok_debug { my $self = shift; my ($trace, $orig_name) = @_; my $is_todo = defined($self->todo); my $msg = $is_todo ? "Failed (TODO)" : "Failed"; my (undef, $file, $line) = $trace->call; if (defined $orig_name) { $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } sub _unoverload { my ($self, $type, $thing) = @_; return unless ref $$thing; return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); { local ($!, $@); require overload; } my $string_meth = overload::Method( $$thing, $type ) || return; $$thing = $$thing->$string_meth(); } sub _unoverload_str { my $self = shift; $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', $_ ) for @_; for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my( $self, $val ) = @_; # Objects are not dualvars. return 0 if ref $val; no warnings 'numeric'; my $numval = $val + 0; return ($numval != 0 and $numval ne $val ? 1 : 0); } sub is_eq { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } sub _diag_fmt { my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } return; } sub _is_diag { my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: $expect DIAGNOSTIC } sub _isnt_diag { my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: anything else DIAGNOSTIC } sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); } sub like { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); } my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); # Bad, these are not comparison operators. Should we include more? my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $ctx = $self->ctx; if ($cmp_ok_bl{$type}) { $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $ctx->trace->call(); # This is so that warnings come out at the caller's level $succ = eval qq[ #line $line "(eval in cmp_ok) $file" \$test = (\$got $type \$expect); 1; ]; $error = $@; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->diag(<<"END") unless $succ; An error occurred while using $type: ------------------------------------ $error ------------------------------------ END unless($ok) { $self->$unoverload( \$got, \$expect ); if( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { no warnings; my $eq = ($got eq $expect || $got == $expect) && ( (defined($got) xor defined($expect)) || (length($got) != length($expect)) ); use warnings; if ($eq) { $self->_cmp_diag( $got, $type, $expect ); } else { $self->_isnt_diag( $got, $type ); } } else { $self->_cmp_diag( $got, $type, $expect ); } } return release $ctx, $ok; } sub _cmp_diag { my( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); $got $type $expect DIAGNOSTIC } sub _caller_context { my $self = shift; my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } sub BAIL_OUT { my( $self, $reason ) = @_; my $ctx = $self->ctx; $self->{Bailed_Out} = 1; $ctx->bail($reason); } { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } sub skip { my( $self, $why, $name ) = @_; $why ||= ''; $name = '' unless defined $name; $self->_unoverload_str( \$why ); my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 1, name => $name, type => 'skip', reason => $why, } unless $self->{no_log_results}; $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $name =~ s{\n}{\n# }sg; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; $tctx->skip('', $why); return release $ctx, 1; } sub todo_skip { my( $self, $why ) = @_; $why ||= ''; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } unless $self->{no_log_results}; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); return release $ctx, 1; } sub maybe_regex { my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my( $re, $opts ); # Check for qr/foo/ if( _is_qr($regex) ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _is_qr { my $regex = shift; # is_regexp() checks for regexes in a robust manner, say if they're # blessed. return re::is_regexp($regex) if defined &re::is_regexp; return ref $regex eq 'Regexp'; } sub _regex_ok { my( $self, $thing, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless( defined $usable_regex ) { local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { my $test; my $context = $self->_caller_context; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval # No point in issuing an uninit warning, they'll see it in the diagnostics no warnings 'uninitialized'; $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; } $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $thing = defined $thing ? "'$thing'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || eval { tied($maybe_fh)->can('TIEHANDLE') }; } sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } sub use_numbers { my( $self, $use_nums ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { warn "The current formatter does not support 'use_numbers'" if $format; return release $ctx, 0; } $format->set_no_numbers(!$use_nums) if defined $use_nums; return release $ctx, $format->no_numbers ? 0 : 1; } BEGIN { for my $method (qw(no_header no_diag)) { my $set = "set_$method"; my $code = sub { my( $self, $no ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can($set)) { warn "The current formatter does not support '$method'" if $format; $ctx->release; return } $format->$set($no) if defined $no; return release $ctx, $format->$method ? 1 : 0; }; no strict 'refs'; ## no critic *$method = $code; } } sub no_ending { my( $self, $no ) = @_; my $ctx = $self->ctx; $ctx->hub->set_no_ending($no) if defined $no; return release $ctx, $ctx->hub->no_ending; } sub diag { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDERR $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->diag($text); $ctx->release; return 0; } sub note { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDOUT $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->note($text); $ctx->release; return 0; } sub explain { my $self = shift; local ($@, $!); require Data::Dumper; return map { ref $_ ? do { my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } sub output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; } sub failure_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; } sub todo_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test::Builder::Formatter'); $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; } sub _new_fh { my $self = shift; my($file_or_fh) = shift; my $fh; if( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } elsif( ref $file_or_fh eq 'SCALAR' ) { # Scalar refs as filehandles was added in 5.8. if( $] >= 5.008 ) { open $fh, ">>", $file_or_fh or $self->croak("Can't open scalar ref $file_or_fh: $!"); } # Emulate scalar ref filehandles with a tie. else { $fh = Test::Builder::IO::Scalar->new($file_or_fh) or $self->croak("Can't tie scalar ref $file_or_fh"); } } else { open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; return; } sub reset_outputs { my $self = shift; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; return; } sub carp { my $self = shift; my $ctx = $self->ctx; $ctx->alert(join "", @_); $ctx->release; } sub croak { my $self = shift; my $ctx = $self->ctx; $ctx->throw(join "", @_); $ctx->release; } sub current_test { my( $self, $num ) = @_; my $ctx = $self->ctx; my $hub = $ctx->hub; if( defined $num ) { $hub->set_count($num); unless ($self->{no_log_results}) { # If the test counter is being pushed forward fill in the details. my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; if ($num > @$test_results) { my $start = @$test_results ? @$test_results : 0; for ($start .. $num - 1) { $test_results->[$_] = { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef }; } } # If backward, wipe history. Its their funeral. elsif ($num < @$test_results) { $#{$test_results} = $num - 1; } } } return release $ctx, $hub->count; } sub is_passing { my $self = shift; my $ctx = $self->ctx; my $hub = $ctx->hub; if( @_ ) { my ($bool) = @_; $hub->set_failed(0) if $bool; $hub->is_passing($bool); } return release $ctx, $hub->is_passing; } sub summary { my($self) = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return map { $_ ? $_->{'ok'} : () } @$data; } sub details { my $self = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return @$data; } sub find_TODO { my( $self, $pack, $set, $new_value ) = @_; my $ctx = $self->ctx; $pack ||= $ctx->trace->package || $self->exported_to; $ctx->release; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; my $old_value = ${ $pack . '::TODO' }; $set and ${ $pack . '::TODO' } = $new_value; return $old_value; } sub todo { my( $self, $pack ) = @_; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return $meta->[-1]->[1] if $meta && @$meta; $pack ||= $ctx->trace->package; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; return ${ $pack . '::TODO' }; } sub in_todo { my $self = shift; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return 1 if $meta && @$meta; my $pack = $ctx->trace->package || return 0; no strict 'refs'; ## no critic no warnings 'once'; my $todo = ${ $pack . '::TODO' }; return 0 unless defined $todo; return 0 if "$todo" eq ''; return 1; } sub todo_start { my $self = shift; my $message = @_ ? shift : ''; my $ctx = $self->ctx; my $hub = $ctx->hub; my $filter = $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; # Set todo on ok's if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { $e->set_todo($message); $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $message; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1); push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; $ctx->release; return; } sub todo_end { my $self = shift; my $ctx = $self->ctx; my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; $ctx->throw('todo_end() called without todo_start()') unless $set; $ctx->hub->pre_unfilter($set->[0]); $ctx->release; return; } sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self ) = @_; my $ctx = $self->ctx; my $trace = $ctx->trace; $ctx->release; return wantarray ? $trace->call : $trace->package; } sub _try { my( $self, $code, %opts ) = @_; my $error; my $return; { local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. $return = eval { $code->() }; $error = $@; } die $error if $error and $opts{die_on_fail}; return wantarray ? ( $return, $error ) : $return; } sub _ending { my $self = shift; my ($ctx, $real_exit_code, $new) = @_; unless ($ctx) { my $octx = $self->ctx; $ctx = $octx->snapshot; $octx->release; } return if $ctx->hub->no_ending; return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. return unless $self->{Original_Pid} == $$; my $hub = $ctx->hub; return if $hub->bailed_out; my $plan = $hub->plan; my $count = $hub->count; my $failed = $hub->failed; my $passed = $hub->is_passing; return unless $plan || $count || $failed; # Ran tests but never declared a plan or hit done_testing if( !$hub->plan and $hub->count ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } # But if the tests ran, handle exit code. if($failed > 0) { my $exit_code = $failed <= 254 ? $failed : 254; $$new ||= $exit_code; return; } $$new ||= 254; return; } if ($real_exit_code && !$count) { $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); $$new ||= $real_exit_code; return; } return if $plan && "$plan" eq 'SKIP'; if (!$count) { $self->diag('No tests run!'); $$new ||= 255; return; } if ($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } if ($plan eq 'NO PLAN') { $ctx->plan( $count ); $plan = $hub->plan; } # Figure out if we passed or failed and print helpful messages. my $num_extra = $count - $plan; if ($num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $ctx->diag(<<"FAIL"); All assertions passed, but errors were encountered. FAIL } my $exit_code = 0; if ($failed) { $exit_code = $failed <= 254 ? $failed : 254; } elsif ($num_extra != 0) { $exit_code = 255; } elsif (!$passed) { $exit_code = 255; } $$new ||= $exit_code; return; } # Some things used this even though it was private... I am looking at you # Test::Builder::Prefix... sub _print_comment { my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape the beginning, _print will take care of the rest. $msg =~ s/^/# /; local( $\, $", $, ) = ( undef, ' ', '' ); print $fh $msg; return 0; } # This is used by Test::SharedFork to turn on IPC after the fact. Not # documenting because I do not want it used. The method name is borrowed from # Test::Builder 2 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork # will be made smarter. sub coordinate_forks { my $self = shift; { local ($@, $!); require Test2::IPC; } Test2::IPC->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_load(); my $ipc = Test2::IPC::apply_ipc($self->{Stack}); $ipc->set_no_fatal(1); Test2::API::test2_no_wait(1); Test2::API::test2_ipc_enable_shm(); } sub no_log_results { $_[0]->{no_log_results} = 1 } 1; __END__ =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use base 'Test::Builder::Module'; my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; my $tb = $CLASS->builder; $tb->ok($test, $name); } =head1 DESCRIPTION L and L have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program C always returns the same Test::Builder object. No matter how many times you call C, you're getting the same object. This is called a singleton. This is done so that multiple modules share such global information as the test counter and where test output is going. If you want a completely new Test::Builder object different from the singleton, use C. =item B my $Test = Test::Builder->create; Ok, so there can be more than one Test::Builder object and this is how you get it. You might use this instead of C if you're testing a Test::Builder based module, but otherwise you probably want C. B: the implementation is not complete. C, for example, is still shared by B Test::Builder objects, even ones created using this method. Also, the method name may change in the future. =item B $builder->subtest($name, \&subtests, @args); See documentation of C in Test::More. C also, and optionally, accepts arguments which will be passed to the subtests reference. =item B diag $builder->name; Returns the name of the current builder. Top level builders default to C<$0> (the name of the executable). Child builders are named via the C method. If no name is supplied, will be named "Child of $parent->name". =item B $Test->reset; Reinitializes the Test::Builder singleton to its original state. Mostly useful for tests run in persistent environments where the same test might be run multiple times in the same process. =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call C, don't call any of the other methods below. =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the number of tests we expect this test to run and prints out the appropriate headers. =item B $Test->no_plan; Declares that this test will run an indeterminate number of tests. =item B $Test->done_testing(); $Test->done_testing($num_tests); Declares that you are done testing, no more tests will be run after this point. If a plan has not yet been output, it will do so. $num_tests is the number of tests you planned to run. If a numbered plan was already declared, and if this contradicts, a failing test will be run to reflect the planning mistake. If C was declared, this will override. If C is called twice, the second call will issue a failing test. If C<$num_tests> is omitted, the number of tests run will be used, like no_plan. C is, in effect, used when you'd want to use C, but safer. You'd use it like so: $Test->ok($a == $b); $Test->done_testing(); Or to plan a variable number of tests: for my $test (@tests) { $Test->ok($test); } $Test->done_testing(scalar @tests); =item B $plan = $Test->has_plan Find out whether a plan has been defined. C<$plan> is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given C<$reason>. Exits immediately with 0. =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This method isn't terribly useful since modules which share the same Test::Builder object might get exported to different packages and only the last one will be honored. =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. They all return true if the test passed, false if the test failed. C<$name> is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if C<$test> is true, fail if $test is false. Just like Test::Simple's C. =item B $Test->is_eq($got, $expected, $name); Like Test::More's C. Checks if C<$got eq $expected>. This is the string version. C only ever matches another C. =item B $Test->is_num($got, $expected, $name); Like Test::More's C. Checks if C<$got == $expected>. This is the numeric version. C only ever matches another C. =item B $Test->isnt_eq($got, $dont_expect, $name); Like L's C. Checks if C<$got ne $dont_expect>. This is the string version. =item B $Test->isnt_num($got, $dont_expect, $name); Like L's C. Checks if C<$got ne $dont_expect>. This is the numeric version. =item B $Test->like($thing, qr/$regex/, $name); $Test->like($thing, '/$regex/', $name); Like L's C. Checks if $thing matches the given C<$regex>. =item B $Test->unlike($thing, qr/$regex/, $name); $Test->unlike($thing, '/$regex/', $name); Like L's C. Checks if $thing B the given C<$regex>. =item B $Test->cmp_ok($thing, $type, $that, $name); Works just like L's C. $Test->cmp_ok($big_num, '!=', $other_big_num); =back =head2 Other Testing Methods These are methods which are used in the course of writing a test but are not themselves tests. =over 4 =item B $Test->BAIL_OUT($reason); Indicates to the L that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =for deprecated BAIL_OUT() used to be BAILOUT() =item B $Test->skip; $Test->skip($why); Skips the current test, reporting C<$why>. =item B $Test->todo_skip; $Test->todo_skip($why); Like C, only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like C, only it skips all the rest of the tests you plan to run and terminates the test. If you're running under C, it skips once and terminates the test. =end _unimplemented =back =head2 Test building utility methods These methods are useful when writing your own test methods. =over 4 =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); This method used to be useful back when Test::Builder worked on Perls before 5.6 which didn't have qr//. Now its pretty useless. Convenience method for building testing functions that take regular expressions as arguments. Takes a quoted regular expression produced by C, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or C if its argument is not recognized. For example, a version of C, sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $thing, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($thing =~ m/$usable_regex/, $name); } =item B my $is_fh = $Test->is_fh($thing); Determines if the given C<$thing> can be used as a filehandle. =cut =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should C<$Test> look when reporting where the test failed. Defaults to 1. Setting C<$Test::Builder::Level> overrides. This is typically useful localized: sub my_ok { my $test = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; $TB->ok($test); } To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Defaults to on. =item B $Test->no_diag($no_diag); If set true no diagnostics will be printed. This includes calls to C. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described below. If this is true, none of that will be done. =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given C<@msgs>. Like C, arguments are simply appended together. Normally, it uses the C handle, but if this is for a TODO test, the C handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because C is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =item B $Test->note(@msgs); Like C, but it prints to the C handle so it will not normally be seen by the user except in verbose mode. =item B my @dump = $Test->explain(@msgs); Will dump the contents of any references in a human readable format. Handy for things like... is_deeply($have, $want) || diag explain $have; or is_deeply($have, $want) || note explain $have; =item B =item B =item B my $filehandle = $Test->output; $Test->output($filehandle); $Test->output($filename); $Test->output(\$scalar); These methods control where Test::Builder will print its output. They take either an open C<$filehandle>, a C<$filename> to open and write to or a C<$scalar> reference to append to. It will always return a C<$filehandle>. B is where normal "ok/not ok" test output goes. Defaults to STDOUT. B is where diagnostic output on test failures and C goes. It is normally not read by Test::Harness and instead is displayed to the user. Defaults to STDERR. C is used instead of C for the diagnostics of a failing TODO test. These will not be seen by the user. Defaults to STDOUT. =item reset_outputs $tb->reset_outputs; Resets all the output filehandles back to their defaults. =item carp $tb->carp(@message); Warns with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =item croak $tb->croak(@message); Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =back =head2 Test Status and Info =over 4 =item B This will turn off result long-term storage. Calling this method will make C
and C useless. You may want to use this if you are running enough tests to fill up all available memory. Test::Builder->new->no_log_results(); There is no way to turn it back on. =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test number we're on. You usually shouldn't have to set this. If set forward, the details of the missing tests are filled in as 'unknown'. if set backward, the details of the intervening tests are deleted. You can erase history if you really want to. =item B my $ok = $builder->is_passing; Indicates if the test suite is currently passing. More formally, it will be false if anything has happened which makes it impossible for the test suite to pass. True otherwise. For example, if no tests have run C will be true because even though a suite with no tests is a failure you can add a passing test to it and start passing. Don't think about it too much. =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =item B
my @tests = $Test->details; Like C, but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when C is changed. In these cases, Test::Builder doesn't know the result of the test, so its type is 'unknown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left C. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since its todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); If the current tests are considered "TODO" it will return the reason, if any. This reason can come from a C<$TODO> variable or the last call to C. Since a TODO test does not need a reason, this function can return an empty string even when inside a TODO block. Use C<< $Test->in_todo >> to determine if you are currently inside a TODO block. C is about finding the right package to look for C<$TODO> in. It's pretty good at guessing the right package to look at. It first looks for the caller based on C<$Level + 1>, since C is usually called inside a test function. As a last resort it will use C. Sometimes there is some confusion about where C should be looking for the C<$TODO> variable. If you want to be sure, tell it explicitly what $pack to use. =item B my $todo_reason = $Test->find_TODO(); my $todo_reason = $Test->find_TODO($pack); Like C but only returns the value of C<$TODO> ignoring C. Can also be used to set C<$TODO> to a new value while returning the old value: my $old_reason = $Test->find_TODO($pack, 1, $new_reason); =item B my $in_todo = $Test->in_todo; Returns true if the test is currently inside a TODO block. =item B $Test->todo_start(); $Test->todo_start($message); This method allows you declare all subsequent tests as TODO tests, up until the C method has been called. The C and C<$TODO> syntax is generally pretty good about figuring out whether or not we're in a TODO test. However, often we find that this is not possible to determine (such as when we want to use C<$TODO> but the tests are being executed in other packages which can't be inferred beforehand). Note that you can use this to nest "todo" tests $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; This is generally not recommended, but large testing systems often have weird internal needs. We've tried to make this also work with the TODO: syntax, but it's not guaranteed and its use is also discouraged: TODO: { local $TODO = 'We have work to do!'; $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; } Pick one style or another of "TODO" to be on the safe side. =item C $Test->todo_end; Stops running tests as "TODO" tests. This method is fatal if called without a preceding C method call. =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal C, except it reports according to your C. C<$height> will be added to the C. If C winds up off the top of the stack it report the highest context. =back =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Builder will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. =head1 THREADS In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is shared by all threads. This means if one thread sets the test number using C they will all be effected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. Test::Builder is only thread-aware if threads.pm is loaded I Test::Builder. You can directly disable thread support with one of the following: $ENV{T2_NO_IPC} = 1 or no Test2::IPC; or Test2::API::test2_ipc_disable() =head1 MEMORY An informative hash, accessible via C, is stored for each test you perform. So memory usage will scale linearly with each test run. Although this is not a problem for most test suites, it can become an issue if you do large (hundred thousands to million) combinatorics tests in the same run. In such cases, you are advised to either split the test file into smaller ones, or use a reverse approach, doing "normal" (code) compares and triggering C should anything go unexpected. Future versions of Test::Builder will have a way to turn history off. =head1 EXAMPLES CPAN can provide the best examples. L, L, L and L all use Test::Builder. =head1 SEE ALSO L, L, L =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F Test-Simple-1.302125/lib/Test/use/0000755000175000017500000000000013243466361016326 5ustar exodistexodistTest-Simple-1.302125/lib/Test/use/ok.pm0000644000175000017500000000252013243466361017274 0ustar exodistexodistpackage Test::use::ok; use 5.005; our $VERSION = '1.302125'; __END__ =head1 NAME Test::use::ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION According to the B documentation, it is recommended to run C inside a C block, so functions are exported at compile-time and prototypes are properly honored. That is, instead of writing this: use_ok( 'Some::Module' ); use_ok( 'Other::Module' ); One should write this: BEGIN { use_ok( 'Some::Module' ); } BEGIN { use_ok( 'Other::Module' ); } However, people often either forget to add C, or mistakenly group C with other tests in a single C block, which can create subtle differences in execution order. With this module, simply change all C in test scripts to C, and they will be executed at C time. The explicit space after C makes it clear that this is a single compile-time action. =head1 SEE ALSO L =head1 MAINTAINER =over 4 =item Chad Granum Eexodist@cpan.orgE =back =encoding utf8 =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. This work is published from Taiwan. L =cut Test-Simple-1.302125/lib/Test/Simple.pm0000644000175000017500000001453413243466361017330 0ustar exodistexodistpackage Test::Simple; use 5.006; use strict; our $VERSION = '1.302125'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok); my $CLASS = __PACKAGE__; =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first!> ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the C function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); C is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. C prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) return $CLASS->builder->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets L know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test 'Rating() get' # in t/film.t at line 14. ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.6.0. Test::Simple is thread-safe in perl 5.8.1 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at L. Test::Simple is 100% forward compatible with L (i.e. you can just use L instead of Test::Simple in your programs and things will still work). =back Look in L's SEE ALSO for more testing modules. =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Test-Simple-1.302125/lib/Test/Tester.pm0000644000175000017500000004363613243466361017352 0ustar exodistexodistuse strict; package Test::Tester; BEGIN { if (*Test::Builder::new{CODE}) { warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" } } use Test::Builder; use Test::Tester::CaptureRunner; use Test::Tester::Delegate; require Exporter; use vars qw( @ISA @EXPORT ); our $VERSION = '1.302125'; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); my $Test = Test::Builder->new; my $Capture = Test::Tester::Capture->new; my $Delegator = Test::Tester::Delegate->new; $Delegator->{Object} = $Test; my $runner = Test::Tester::CaptureRunner->new; my $want_space = $ENV{TESTTESTERSPACE}; sub show_space { $want_space = 1; } my $colour = ''; my $reset = ''; if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) { if (eval { require Term::ANSIColor; 1 }) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms my ($f, $b) = split(",", $want_colour); $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); $reset = Term::ANSIColor::color("reset"); } } sub new_new { return $Delegator; } sub capture { return Test::Tester::Capture->new; } sub fh { # experiment with capturing output, I don't like it $runner = Test::Tester::FHRunner->new; return $Test; } sub find_run_tests { my $d = 1; my $found = 0; while ((not $found) and (my ($sub) = (caller($d))[3]) ) { # print "$d: $sub\n"; $found = ($sub eq "Test::Tester::run_tests"); $d++; } # die "Didn't find 'run_tests' in caller stack" unless $found; return $d; } sub run_tests { local($Delegator->{Object}) = $Capture; $runner->run_tests(@_); return ($runner->get_premature, $runner->get_results); } sub check_test { my $test = shift; my $expect = shift; my $name = shift; $name = "" unless defined($name); @_ = ($test, [$expect], $name); goto &check_tests; } sub check_tests { my $test = shift; my $expects = shift; my $name = shift; $name = "" unless defined($name); my ($prem, @results) = eval { run_tests($test, $name) }; $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || $Test->diag("Before any testing anything, your tests said\n$prem"); local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_results(\@results, $expects, $name); return ($prem, @results); } sub cmp_field { my ($result, $expect, $field, $desc) = @_; if (defined $expect->{$field}) { $Test->is_eq($result->{$field}, $expect->{$field}, "$desc compare $field"); } } sub cmp_result { my ($result, $expect, $name) = @_; my $sub_name = $result->{name}; $sub_name = "" unless defined($name); my $desc = "subtest '$sub_name' of '$name'"; { local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_field($result, $expect, "ok", $desc); cmp_field($result, $expect, "actual_ok", $desc); cmp_field($result, $expect, "type", $desc); cmp_field($result, $expect, "reason", $desc); cmp_field($result, $expect, "name", $desc); } # if we got no depth then default to 1 my $depth = 1; if (exists $expect->{depth}) { $depth = $expect->{depth}; } # if depth was explicitly undef then don't test it if (defined $depth) { $Test->is_eq($result->{depth}, $depth, "checking depth") || $Test->diag('You need to change $Test::Builder::Level'); } if (defined(my $exp = $expect->{diag})) { my $got = ''; if (ref $exp eq 'Regexp') { if (not $Test->like($result->{diag}, $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } else { # if there actually is some diag then put a \n on the end if it's not # there already $exp .= "\n" if (length($exp) and $exp !~ /\n$/); if (not $Test->ok($result->{diag} eq $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } if ($got) { my $glen = length($got); my $elen = length($exp); for ($got, $exp) { my @lines = split("\n", $_); $_ = join("\n", map { if ($want_space) { $_ = $colour.escape($_).$reset; } else { "'$colour$_$reset'" } } @lines); } $Test->diag(<32 and $c<125) or $c == 10) { $res .= $char; } else { $res .= sprintf('\x{%x}', $c) } } return $res; } sub cmp_results { my ($results, $expects, $name) = @_; $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); for (my $i = 0; $i < @$expects; $i++) { my $expect = $expects->[$i]; my $result = $results->[$i]; local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_result($result, $expect, $name); } } ######## nicked from Test::More sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; { no warnings 'redefine'; *Test::Builder::new = \&new_new; } goto &plan; } sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } ############ 1; __END__ =head1 NAME Test::Tester - Ease testing test modules built with Test::Builder =head1 SYNOPSIS use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_eq("this", "that", "not eq"); }, { ok => 0, # expect this to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); or use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_qr("this", "that", "not matching"); }, { ok => 0, # expect this to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); or use Test::Tester; use Test::More tests => 3; use Test::MyStyle; my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); # now use Test::More::like to check the diagnostic output like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); =head1 DESCRIPTION If you have written a test module based on Test::Builder then Test::Tester allows you to test it with the minimum of effort. =head1 HOW TO USE (THE EASY WAY) From version 0.08 Test::Tester no longer requires you to included anything special in your test modules. All you need to do is use Test::Tester; in your test script B any other Test::Builder based modules and away you go. Other modules based on Test::Builder can be used to help with the testing. In fact you can even use functions from your module to test other functions from the same module (while this is possible it is probably not a good idea, if your module has bugs, then using it to test itself may give the wrong answers). The easiest way to test is to do something like check_test( sub { is_mystyle_eq("this", "that", "not eq") }, { ok => 0, # we expect the test to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); this will execute the is_mystyle_eq test, capturing it's results and checking that they are what was expected. You may need to examine the test results in a more flexible way, for example, the diagnostic output may be quite long or complex or it may involve something that you cannot predict in advance like a timestamp. In this case you can get direct access to the test results: my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); or check_test( sub { is_mystyle_qr("this", "that", "not matching") }, { ok => 0, # we expect the test to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); We cannot predict how long the database ping will take so we use Test::More's like() test to check that the diagnostic string is of the right form. =head1 HOW TO USE (THE HARD WAY) I Make your module use the Test::Tester::Capture object instead of the Test::Builder one. How to do this depends on your module but assuming that your module holds the Test::Builder object in $Test and that all your test routines access it through $Test then providing a function something like this sub set_builder { $Test = shift; } should allow your test scripts to do Test::YourModule::set_builder(Test::Tester->capture); and after that any tests inside your module will captured. =head1 TEST RESULTS The result of each test is captured in a hash. These hashes are the same as the hashes returned by Test::Builder->details but with a couple of extra fields. These fields are documented in L in the details() function =over 2 =item ok Did the test pass? =item actual_ok Did the test really pass? That is, did the pass come from Test::Builder->ok() or did it pass because it was a TODO test? =item name The name supplied for the test. =item type What kind of test? Possibilities include, skip, todo etc. See L for more details. =item reason The reason for the skip, todo etc. See L for more details. =back These fields are exclusive to Test::Tester. =over 2 =item diag Any diagnostics that were output for the test. This only includes diagnostics output B the test result is declared. Note that Test::Builder ensures that any diagnostics end in a \n and it in earlier versions of Test::Tester it was essential that you have the final \n in your expected diagnostics. From version 0.10 onward, Test::Tester will add the \n if you forgot it. It will not add a \n if you are expecting no diagnostics. See below for help tracking down hard to find space and tab related problems. =item depth This allows you to check that your test module is setting the correct value for $Test::Builder::Level and thus giving the correct file and line number when a test fails. It is calculated by looking at caller() and $Test::Builder::Level. It should count how many subroutines there are before jumping into the function you are testing. So for example in run_tests( sub { my_test_function("a", "b") } ); the depth should be 1 and in sub deeper { my_test_function("a", "b") } run_tests(sub { deeper() }); depth should be 2, that is 1 for the sub {} and one for deeper(). This might seem a little complex but if your tests look like the simple examples in this doc then you don't need to worry as the depth will always be 1 and that's what Test::Tester expects by default. B: if you do not specify a value for depth in check_test() then it automatically compares it against 1, if you really want to skip the depth test then pass in undef. B: depth will not be correctly calculated for tests that run from a signal handler or an END block or anywhere else that hides the call stack. =back Some of Test::Tester's functions return arrays of these hashes, just like Test::Builder->details. That is, the hash for the first test will be array element 1 (not 0). Element 0 will not be a hash it will be a string which contains any diagnostic output that came before the first test. This should usually be empty, if it's not, it means something output diagnostics before any test results showed up. =head1 SPACES AND TABS Appearances can be deceptive, especially when it comes to emptiness. If you are scratching your head trying to work out why Test::Tester is saying that your diagnostics are wrong when they look perfectly right then the answer is probably whitespace. From version 0.10 on, Test::Tester surrounds the expected and got diag values with single quotes to make it easier to spot trailing whitespace. So in this example # Got diag (5 bytes): # 'abcd ' # Expected diag (4 bytes): # 'abcd' it is quite clear that there is a space at the end of the first string. Another way to solve this problem is to use colour and inverse video on an ANSI terminal, see below COLOUR below if you want this. Unfortunately this is sometimes not enough, neither colour nor quotes will help you with problems involving tabs, other non-printing characters and certain kinds of problems inherent in Unicode. To deal with this, you can switch Test::Tester into a mode whereby all "tricky" characters are shown as \{xx}. Tricky characters are those with ASCII code less than 33 or higher than 126. This makes the output more difficult to read but much easier to find subtle differences between strings. To turn on this mode either call C in your test script or set the C environment variable to be a true value. The example above would then look like # Got diag (5 bytes): # abcd\x{20} # Expected diag (4 bytes): # abcd =head1 COLOUR If you prefer to use colour as a means of finding tricky whitespace characters then you can set the C environment variable to a comma separated pair of colours, the first for the foreground, the second for the background. For example "white,red" will print white text on a red background. This requires the Term::ANSIColor module. You can specify any colour that would be acceptable to the Term::ANSIColor::color function. If you spell colour differently, that's no problem. The C variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS =head3 ($premature, @results) = run_tests(\&test_sub) \&test_sub is a reference to a subroutine. run_tests runs the subroutine in $test_sub and captures the results of any tests inside it. You can run more than 1 test inside this subroutine if you like. $premature is a string containing any diagnostic output from before the first test. @results is an array of test result hashes. =head3 cmp_result(\%result, \%expect, $name) \%result is a ref to a test result hash. \%expect is a ref to a hash of expected values for the test result. cmp_result compares the result with the expected values. If any differences are found it outputs diagnostics. You may leave out any field from the expected result and cmp_result will not do the comparison of that field. =head3 cmp_results(\@results, \@expects, $name) \@results is a ref to an array of test results. \@expects is a ref to an array of hash refs. cmp_results checks that the results match the expected results and if any differences are found it outputs diagnostics. It first checks that the number of elements in \@results and \@expects is the same. Then it goes through each result checking it against the expected result as in cmp_result() above. =head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) \&test_sub is a reference to a subroutine. \@expect is a ref to an array of hash refs which are expected test results. check_tests combines run_tests and cmp_tests into a single call. It also checks if the tests died at any stage. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) \&test_sub is a reference to a subroutine. \%expect is a ref to an hash of expected values for the test result. check_test is a wrapper around check_tests. It combines run_tests and cmp_tests into a single call, checking if the test died. It assumes that only a single test is run inside \&test_sub and include a test to make sure this is true. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 show_space() Turn on the escaping of characters as described in the SPACES AND TABS section. =head1 HOW IT WORKS Normally, a test module (let's call it Test:MyStyle) calls Test::Builder->new to get the Test::Builder object. Test::MyStyle calls methods on this object to record information about test results. When Test::Tester is loaded, it replaces Test::Builder's new() method with one which returns a Test::Tester::Delegate object. Most of the time this object behaves as the real Test::Builder object. Any methods that are called are delegated to the real Test::Builder object so everything works perfectly. However once we go into test mode, the method calls are no longer passed to the real Test::Builder object, instead they go to the Test::Tester::Capture object. This object seems exactly like the real Test::Builder object, except, instead of outputting test results and diagnostics, it just records all the information for later analysis. =head1 CAVEATS Support for calling Test::Builder->note is minimal. It's implemented as an empty stub, so modules that use it will not crash but the calls are not recorded for testing purposes like the others. Patches welcome. =head1 SEE ALSO L the source of testing goodness. L for an alternative approach to the problem tackled by Test::Tester - captures the strings output by Test::Builder. This means you cannot get separate access to the individual pieces of information and you must predict B what your test will output. =head1 AUTHOR This module is copyright 2005 Fergal Daly , some parts are based on other people's work. Plan handling lifted from Test::More. written by Michael G Schwern . Test::Tester::Capture is a cut down and hacked up version of Test::Builder. Test::Builder was written by chromatic and Michael G Schwern . =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut Test-Simple-1.302125/lib/Test/More.pm0000644000175000017500000014740713243466361017007 0ustar exodistexodistpackage Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause C to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '1.302125'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain subtest BAIL_OUT ); =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => 23; # or use Test::More skip_all => $reason; # or use Test::More; # see done_testing() require_ok( 'Some::Module' ); # Various ways to say "ok" ok($got eq $expected, $test_name); is ($got, $expected, $test_name); isnt($got, $expected, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($got, qr/expected/, $test_name); unlike($got, qr/expected/, $test_name); cmp_ok($got, '==', $expected, $test_name); is_deeply($got_complex_structure, $expected_complex_structure, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); BAIL_OUT($why); # UNIMPLEMENTED!!! my @status = Test::More::status; =head1 DESCRIPTION B If you're just getting started writing tests, have a look at L first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => 23; There are cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare your tests at the end. use Test::More; ... run your tests ... done_testing( $number_of_tests_run ); B C should never be called in an C block. Sometimes you really don't know how many tests were run, or it's too difficult to calculate. In which case you can leave off $number_of_tests_run. In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the C function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } elsif( defined $item and $item eq 'import' ) { if ($import) { push @$import, @{$list->[ ++$idx ]}; } else { $import = $list->[ ++$idx ]; push @other, $item, $import; } } else { push @other, $item; } $idx++; } @$list = @other; if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { my $to = $class->builder->exported_to; no strict 'refs'; *{"$to\::TODO"} = \our $TODO; if ($import) { @$import = grep $_ ne '$TODO', @$import; } else { push @$list, import => [grep $_ ne '$TODO', @EXPORT]; } } return; } =over 4 =item B done_testing(); done_testing($number_of_tests); If you don't know how many tests you're going to run, you can issue the plan when you're done running tests. $number_of_tests is the same as C, it's the number of tests you expected to run. You can omit this, in which case the number of tests you ran doesn't matter, just the fact that your tests ran to conclusion. This is safer than and replaces the "no_plan" plan. B You must never put C inside an C block. The plan is there to ensure your test does not exit before testing has completed. If you use an END block you completely bypass this protection. =back =cut sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($got eq $expected, $test_name); This simply evaluates any expression (C<$got eq $expected> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep(!defined $_, @items), 'all items defined' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an C fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 'sufficient mucus' # in foo.t at line 42. This is the same as L's C routine. =cut sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } =item B =item B is ( $got, $expected, $test_name ); isnt( $got, $expected, $test_name ); Similar to C, C and C compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); C will only ever match C. So you can test a value against C like this: is($not_defined, undef, "undefined as expected"); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. C cannot know what you are testing for (beyond the name), but C and C know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 'Is foo the same as bar?' # in foo.t at line 139. # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use C and C over C where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); This does not check if C is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use C. ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); A simple call to C usually does not provide a strong test but there are cases when you cannot say much more about a value than that it is different from some other value: new_ok $obj, "Foo"; my $clone = $obj->clone; isa_ok $obj, "Foo", "Foo->clone"; isnt $obj, $clone, "clone() produces a different object"; For those grammatical pedants out there, there's an C function which is an alias of C. =cut sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } *isn't = \&isnt; # ' to unconfuse syntax higlighters =item B like( $got, qr/expected/, $test_name ); Similar to C, C matches $got against the regex C. So this: like($got, qr/expected/, 'this is like that'); is similar to: ok( $got =~ m/expected/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $got, '/expected/', 'this is like that' ); Regex options may be placed on the end (C<'/expected/i'>). Its advantages over C are similar to that of C and C. Better diagnostics on failure. =cut sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } =item B unlike( $got, qr/expected/, $test_name ); Works exactly as C, only it checks if $got B match the given pattern. =cut sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } =item B cmp_ok( $got, $op, $expected, $test_name ); Halfway between C and C lies C. This allows you to compare two arguments using any binary perl operator. The test passes if the comparison is true and fails otherwise. # ok( $got eq $expected ); cmp_ok( $got, 'eq', $expected, 'this eq that' ); # ok( $got == $expected ); cmp_ok( $got, '==', $expected, 'this == that' ); # ok( $got && $expected ); cmp_ok( $got, '&&', $expected, 'this && that' ); ...etc... Its advantage over C is when the test fails you'll know what $got and $expected were: not ok 1 # Failed test in foo.t at line 12. # '23' # && # undef It's also useful in those cases where you are comparing numbers and C's use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); It's especially useful when comparing greater-than or smaller-than relation between values: cmp_ok( $some_value, '<=', $upper_limit ); =cut sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single C call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($subclass, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given C<< $object->isa($class) >>. Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. You can also test a class, to make sure that it has the right ancestor: isa_ok( 'Vole', 'Rodent' ); It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; my $whatami; if( !defined $thing ) { $whatami = 'undef'; } elsif( ref $thing ) { $whatami = 'reference'; local($@,$!); require Scalar::Util; if( Scalar::Util::blessed($thing) ) { $whatami = 'object'; } } else { $whatami = 'class'; } # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); if($error) { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } # Special case for isa_ok( [], "ARRAY" ) and like if( $whatami eq 'reference' ) { $rslt = UNIVERSAL::isa($thing, $class); } my($diag, $name); if( defined $thing_name ) { $name = "'$thing_name' isa '$class'"; $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; } elsif( $whatami eq 'object' ) { my $my_class = ref $thing; $thing_name = qq[An object of class '$my_class']; $name = "$thing_name isa '$class'"; $diag = "The object of class '$my_class' isn't a '$class'"; } elsif( $whatami eq 'reference' ) { my $type = ref $thing; $thing_name = qq[A reference of type '$type']; $name = "$thing_name isa '$class'"; $diag = "The reference of type '$type' isn't a '$class'"; } elsif( $whatami eq 'undef' ) { $thing_name = 'undef'; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't defined"; } elsif( $whatami eq 'class' ) { $thing_name = qq[The class (or class-like) '$thing']; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't a '$class'"; } else { die; } my $ok; if($rslt) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } return $ok; } =item B my $obj = new_ok( $class ); my $obj = new_ok( $class => \@args ); my $obj = new_ok( $class => \@args, $object_name ); A convenience function which combines creating an object and calling C on that object. It is basically equivalent to: my $obj = $class->new(@args); isa_ok $obj, $class, $object_name; If @args is not given, an empty list will be used. This function only works on C and it assumes C will return just a single object which isa C<$class>. =cut sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $class = 'undef' if !defined $class; $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } return $obj; } =item B subtest $name => \&code, @args; C runs the &code as its own little test with its own plan and its own result. The main test counts this as a single test using the result of the whole subtest to determine if its ok or not ok. For example... use Test::More tests => 3; pass("First test"); subtest 'An example subtest' => sub { plan tests => 2; pass("This is a subtest"); pass("So is this"); }; pass("Third test"); This would produce. 1..3 ok 1 - First test # Subtest: An example subtest 1..2 ok 1 - This is a subtest ok 2 - So is this ok 2 - An example subtest ok 3 - Third test A subtest may call C. No tests will be run, but the subtest is considered a skip. subtest 'skippy' => sub { plan skip_all => 'cuz I said so'; pass('this test will never be run'); }; Returns true if the subtest passed, false otherwise. Due to how subtests work, you may omit a plan if you desire. This adds an implicit C to the end of your subtest. The following two subtests are equivalent: subtest 'subtest with implicit done_testing()', sub { ok 1, 'subtests with an implicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; }; subtest 'subtest with explicit done_testing()', sub { ok 1, 'subtests with an explicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; done_testing(); }; Extra arguments given to C are passed to the callback. For example: sub my_subtest { my $range = shift; ... } for my $range (1, 10, 100, 1000) { subtest "testing range $range", \&my_subtest, $range; } =cut sub subtest { my $tb = Test::More->builder; return $tb->subtest(@_); } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an C. In this case, you can simply use C (to declare the test ok) or fail (for not ok). They are synonyms for C and C. Use these very, very, very sparingly. =cut sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } =back =head2 Module tests Sometimes you want to test if a module, or a list of modules, can successfully load. For example, you'll often want a first test which simply loads all the modules in the distribution to make sure they work before going on to do more complicated testing. For such purposes we have C and C. =over 4 =item B require_ok($module); require_ok($file); Tries to C the given $module or $file. If it loads successfully, the test will pass. Otherwise it fails and displays the load error. C will guess whether the input is a module name or a filename. No exception will be thrown if the load fails. # require Some::Module require_ok "Some::Module"; # require "Some/File.pl"; require_ok "Some/File.pl"; # stop testing if any of your modules will not load for my $module (@module) { require_ok $module or BAIL_OUT "Can't load $module"; } =cut sub require_ok ($) { my($module) = shift; my $tb = Test::More->builder; my $pack = caller; # Try to determine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(< BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } Like C, but it will C the $module in question and only loads modules, not files. If you just want to test a module can be loaded, use C. If you just want to load a module in a test, we recommend simply using C directly. It will cause the test to stop. It's recommended that you run C inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); Version numbers can be checked like so: # Just like "use Some::Module 1.02" BEGIN { use_ok('Some::Module', 1.02) } Don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } because the notion of "compile-time" is relative. Instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } If you want the equivalent of C, use a module but not import anything, use C. BEGIN { require_ok "Foo" } =cut sub use_ok ($;@) { my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my %caller; @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(< I'm not quite sure what will happen with filehandles. =over 4 =item B is_deeply( $got, $expected, $test_name ); Similar to C, except that if $got and $expected are references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. C compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". C currently has very limited handling of function reference and globs. It merely checks if they have the same referent. This may improve in the future. L and L provide more in-depth functionality along these lines. B is_deeply() has limitations when it comes to comparing strings and refs: my $path = path('.'); my $hash = {}; is_deeply( $path, "$path" ); # ok is_deeply( $hash, "$hash" ); # fail This happens because is_deeply will unoverload all arguments unconditionally. It is probably best not to use is_deeply with overloading. For legacy reasons this is not likely to ever be fixed. If you would like a much better tool for this you should see L Specifically L has an C function that works like C with many improvements. =cut our( @Data_Stack, %Refs_Seen ); my $DNE = bless [], 'Does::Not::Exist'; sub _dne { return ref $_[0] eq ref $DNE; } ## no critic (Subroutines::RequireArgUnpacking) sub is_deeply { my $tb = Test::More->builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Like C @diagnostic_message is simply concatenated together. Returns false, so as to preserve failure. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test 'There's a foo user' # in foo.t at line 52. # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it won't interfere with the test. =item B note(@diagnostic_message); Like C, except the message will not be seen when the test is run in a harness. It will only be visible in the verbose TAP stream. Handy for putting in notes which might be useful for debugging, but don't indicate a problem. note("Tempfile is $tempfile"); =cut sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } =item B my @dump = explain @diagnostic_message; Will dump the contents of any references in a human readable format. Usually you want to pass this into C or C. Handy for things like... is_deeply($have, $want) || diag explain $have; or note explain \%args; Some::Class->method(%args); =cut sub explain { return Test::More->builder->explain(@_); } =back =head2 Conditional tests Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented (such as C on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). For more details on the mechanics of skip and todo tests see L. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. If your plan is C $how_many is optional and will default to 1. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; # If the plan is set, and is static, then skip needs a count. If the plan # is 'no_plan' we are fine. As well if plan is undefined then we are # waiting for done_testing. unless (defined $how_many) { my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" if $plan && $plan =~ m/^\d+$/; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". L will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. L will interpret them as passing. =cut sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like C or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Test control =over 4 =item B BAIL_OUT($reason); Indicates to the harness that things are going so badly all testing should terminate. This includes the running of any additional test scripts. This is typically used when testing cannot continue such as a critical module failing to compile or a necessary external utility not being available such as a database connection failing. The test will exit with 255. For even better control look at L. =cut sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } =back =head2 Discouraged comparison functions The use of the following functions is discouraged as they are not actually testing functions and produce no diagnostics to help figure out what went wrong. They were written before C existed because I couldn't figure out how to display a useful diff of two arbitrary data structures. These functions are usually used inside an C. ok( eq_array(\@got, \@expected) ); C can do that better and with diagnostics. is_deeply( \@got, \@expected ); They may be deprecated in future versions. =over 4 =item B my $is_eq = eq_array(\@got, \@expected); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _equal_nonrefs { my( $e1, $e2 ) = @_; return if ref $e1 or ref $e2; if ( defined $e1 ) { return 1 if defined $e2 and $e1 eq $e2; } else { return 1 if !defined $e2; } return; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both undefined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } =item B my $is_eq = eq_hash(\%got, \%expected); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B my $is_eq = eq_set(\@got, \@expected); Similar to C, except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. ok( eq_set(\@got, \@expected) ); Is better written: is_deeply( [sort @got], [sort @expected] ); B By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. B C does not know how to deal with references at the top level. The following is an example of a comparison which might not work: eq_set([\1, \2], [\2, \1]); L contains much better set comparison functions. =cut sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of L which provides a single, unified backend for any test library to use. This means two test libraries which both use B be used together in the same program>. If you simply want to do a little tweaking of how the tests behave, you can access the underlying L object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the L object underlying Test::More for you to play with. =back =head1 EXIT CODES If all your tests passed, L will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run L will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. B This behavior may go away in future versions. =head1 COMPATIBILITY Test::More works with Perls as old as 5.8.1. Thread support is not very reliable before 5.10.1, but that's because threads are not very reliable before 5.10.1. Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. Key feature milestones include: =over 4 =item subtests Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. =item C This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C Although C was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C C and C These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =back There is a full version history in the Changes file, and the Test::More versions included as core can be found using L: $ corelist -a Test::More =head1 CAVEATS and NOTES =over 4 =item utf8 / "Wide character in print" If you use utf8 or other non-ASCII characters with Test::More you might get a "Wide character in print" warning. Using C<< binmode STDOUT, ":utf8" >> will not fix it. L (which powers Test::More) duplicates STDOUT and STDERR. So any changes to them, including changing their output disciplines, will not be seem by Test::More. One work around is to apply encodings to STDOUT and STDERR as early as possible and before Test::More (or any other Test module) loads. use open ':std', ':encoding(utf8)'; use Test::More; A more direct work around is to change the filehandles used by L. my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; =item Overloaded objects String overloaded objects are compared B (or in C's case, strings or numbers as appropriate to the comparison op). This prevents Test::More from piercing an object's interface allowing better blackbox testing. So if a function starts returning overloaded objects instead of bare strings your tests won't notice the difference. This is good. However, it does mean that functions like C cannot be used to test the internals of string overloaded objects. In this case I would suggest L which contains more flexible testing functions for complex data structures. =item Threads Test::More will only be aware of threads if C has been done I Test::More is loaded. This is ok: use threads; use Test::More; This may cause problems: use Test::More use threads; 5.8.1 and above are supported. Anything below that has too many bugs. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's L module. I was largely unaware of its existence when I'd first written my own C routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO =head2 =head2 ALTERNATIVES L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L tests written with Test.pm, the original testing module, do not play well with other testing libraries. Test::Legacy emulates the Test.pm interface and does play well with others. =head2 TESTING FRAMEWORKS L The Fennec framework is a testers toolbox. It uses L under the hood. It brings enhancements for forking, defining state, and mocking. Fennec enhances several modules to work better together than they would if you loaded them individually on your own. L Provides enhanced (L) syntax for Fennec. =head2 ADDITIONAL LIBRARIES L for more ways to test complex data structures. And it plays well with Test::More. L is like xUnit but more perlish. L gives you more powerful complex data structure testing. L shows the idea of embedded testing. L The ultimate mocking library. Easily spawn objects defined on the fly. Can also override, block, or reimplement packages as needed. L Quickly define fixture data for unit tests. =head2 OTHER COMPONENTS L is the test runner and output interpreter for Perl. It's the thing that powers C and where the C utility comes from. =head2 BUNDLES L Most commonly needed test functions and features. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa gang. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 BUGS See F to report and view bugs. =head1 SOURCE The source code repository for Test::More can be found at F. =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Test-Simple-1.302125/lib/Test2.pm0000644000175000017500000001437113243466361016160 0ustar exodistexodistpackage Test2; use strict; use warnings; our $VERSION = '1.302125'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2 - Framework for writing test tools that all work together. =head1 DESCRIPTION Test2 is a new testing framework produced by forking L, completely refactoring it, adding many new features and capabilities. =head2 WHAT IS NEW? =over 4 =item Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with C. =item Better diagnostics capabilities. Test2 uses an L object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. =item Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. =item More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. =item Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. =item Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. =item Support for threading/forking. Test2 support for forking and threading can be turned on using L. Once turned on threading and forking operate sanely and work as one would expect. =back =head1 GETTING STARTED If you are interested in writing tests using new tools then you should look at L. L is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at L first. =head1 NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in L. =head2 Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like C and C. Most things written for Test2 should go here. Modules in this namespace B export subs from other tools. See the L namespace if you want to do that. =head2 Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. =head2 Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. =head2 Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. =head2 Test2::Formatter:: Formatters live under this namespace. L is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. =head2 Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. =head2 Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. =head2 Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. =head3 Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. =head2 Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. =head2 Test2::API:: This is for Test2 API and related packages. =head2 Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into C. =head1 SEE ALSO L - Primary API functions. L - Detailed documentation of the context object. L - The IPC system used for threading/fork support. L - Formatters such as TAP live here. L - Events live in this namespace. L - All events eventually funnel through a hub. Custom hubs are how C and C are implemented. =head1 CONTACTING US Many Test2 developers and users lurk on L and L. We also have a slack team that can be joined by anyone with an C<@cpan.org> email address L If you do not have an C<@cpan.org> email you can ask for a slack invite by emailing Chad Granum Eexodist@cpan.orgE. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test-Simple-1.302125/lib/ok.pm0000644000175000017500000000170713243466361015567 0ustar exodistexodistpackage ok; our $VERSION = '1.302125'; use strict; use Test::More (); sub import { shift; if (@_) { goto &Test::More::pass if $_[0] eq 'ok'; goto &Test::More::use_ok; } # No argument list - croak as if we are prototyped like use_ok() my (undef, $file, $line) = caller(); ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; } __END__ =encoding UTF-8 =head1 NAME ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION With this module, simply change all C in test scripts to C, and they will be executed at C time. Please see L for the full description. =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. This work is published from Taiwan. L =cut Test-Simple-1.302125/META.yml0000644000175000017500000000254313243466361015322 0ustar exodistexodist--- abstract: 'Basic utilities for writing tests.' author: - 'Chad Granum ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Simple requires: File::Spec: '0' File::Temp: '0' Scalar::Util: '1.13' Storable: '0' perl: '5.006002' utf8: '0' resources: bugtracker: http://github.com/Test-More/test-more/issues repository: http://github.com/Test-More/test-more/ version: '1.302125' x_breaks: Log::Dispatch::Config::TestLog: '<= 0.02' Net::BitTorrent: '<= 0.052' Test2::Harness: '<= 0.000013' Test2::Tools::EventDumper: '<= 0.000007' Test::Able: '<= 0.11' Test::Aggregate: '<= 0.373' Test::Alien: '<= 0.04' Test::Builder::Clutch: '<= 0.07' Test::Clustericious::Cluster: '<= 0.30' Test::Dist::VersionSync: '<= v1.1.4' Test::Exception: '<= 0.42' Test::Flatten: '<= 0.11' Test::Group: '<= 0.20' Test::Modern: '<= 0.012' Test::Moose: '<= 2.1209' Test::More::Prefix: '<= 0.005' Test::ParallelSubtest: '<= 0.05' Test::Pretty: '<= 0.32' Test::SharedFork: '<= 0.34' Test::UseAllModules: '>= 0.12, <= 0.14' Test::Wrapper: '<= v0.3.0' x_serialization_backend: 'YAML::Tiny version 1.70' Test-Simple-1.302125/cpanfile0000644000175000017500000000057213243466361015555 0ustar exodistexodistrequires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "Scalar::Util" => "1.13"; requires "Storable" => "0"; requires "perl" => "5.006002"; requires "utf8" => "0"; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; }; on 'develop' => sub { requires "IPC::Open3" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Spelling" => "0.12"; }; Test-Simple-1.302125/dist.ini0000644000175000017500000000575013243466361015520 0ustar exodistexodistname = Test-Simple author = Chad Granum license = Perl_5 copyright_holder = Chad Granum [RewriteVersion] ; sets dist version from main module's $VERSION [License] [ManifestSkip] [Manifest] [NextRelease] [GatherDir] exclude_match = ^xt/downstream ; only run these tests locally exclude_filename = LICENSE exclude_filename = Makefile.PL exclude_filename = cpanfile exclude_filename = README exclude_filename = README.md [PodSyntaxTests] [RunExtraTests] [TestRelease] [MetaResources] bugtracker.web = http://github.com/Test-More/test-more/issues repository.url = http://github.com/Test-More/test-more/ repository.type = git [Prereqs] perl = 5.006002 utf8 = 0 File::Spec = 0 File::Temp = 0 Scalar::Util = 1.13 Storable = 0 ; Carp = 0 ; Do not uncomment this, causes cycle in really old perls (#682) [Prereqs / DevelopRequires] Test::Spelling = 0.12 ; for xt/author/pod-spell.t IPC::Open3 = 0 ; for t/Test2/regression/ipc_files_abort_exit.t [Breaks] Log::Dispatch::Config::TestLog = <= 0.02 Net::BitTorrent = <= 0.052 Test::Able = <= 0.11 Test::Aggregate = <= 0.373 Test::Alien = <= 0.04 Test::Builder::Clutch = <= 0.07 Test::Clustericious::Cluster = <= 0.30 Test::Dist::VersionSync = <= 1.1.4 Test::Exception = <= 0.42 Test::Flatten = <= 0.11 Test::Group = <= 0.20 Test::Modern = <= 0.012 Test::Moose = <= 2.1209 Test::More::Prefix = <= 0.005 Test::ParallelSubtest = <= 0.05 Test::Pretty = <= 0.32 Test::SharedFork = <= 0.34 Test::UseAllModules = >= 0.12, <= 0.14 Test::Wrapper = <= 0.3.0 Test2::Tools::EventDumper = <= 0.000007 Test2::Harness = <= 0.000013 ; These have tests that will not pass on old versions, but do not break if ; already installed, no need to notify. ; Test::FITesque ; Test::Module::Used ; Test::Moose::More ; Device::Chip [MakeMaker] [DualLife] [CPANFile] [MetaYAML] [MetaJSON] ; authordep Pod::Markdown [ReadmeFromPod / Markdown] filename = lib/Test2.pm type = markdown readme = README.md [ReadmeFromPod / Text] filename = lib/Test2.pm type = text readme = README [CopyFilesFromBuild] copy = LICENSE copy = cpanfile copy = README copy = README.md copy = Makefile.PL [Git::Check] allow_dirty = Makefile.PL allow_dirty = README allow_dirty = README.md allow_dirty = cpanfile allow_dirty = LICENSE allow_dirty = Changes [Git::Commit] allow_dirty = Makefile.PL allow_dirty = README allow_dirty = README.md allow_dirty = cpanfile allow_dirty = LICENSE allow_dirty = Changes [Git::Tag] [FakeRelease] [BumpVersionAfterRelease] [Git::Commit / Commit_Changes] munge_makefile_pl = true allow_dirty_match = ^lib allow_dirty = Makefile.PL allow_dirty = README allow_dirty = README.md allow_dirty = cpanfile allow_dirty = LICENSE commit_msg = Automated Version Bump Test-Simple-1.302125/MANIFEST0000644000175000017500000002226013243466361015200 0ustar exodistexodist# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.010. Changes LICENSE MANIFEST META.json META.yml Makefile.PL README README.md appveyor.yml cpanfile dist.ini examples/indent.pl examples/subtest.t examples/tools.pl examples/tools.t lib/Test/Builder.pm lib/Test/Builder/Formatter.pm lib/Test/Builder/IO/Scalar.pm lib/Test/Builder/Module.pm lib/Test/Builder/Tester.pm lib/Test/Builder/Tester/Color.pm lib/Test/Builder/TodoDiag.pm lib/Test/More.pm lib/Test/Simple.pm lib/Test/Tester.pm lib/Test/Tester/Capture.pm lib/Test/Tester/CaptureRunner.pm lib/Test/Tester/Delegate.pm lib/Test/Tutorial.pod lib/Test/use/ok.pm lib/Test2.pm lib/Test2/API.pm lib/Test2/API/Breakage.pm lib/Test2/API/Context.pm lib/Test2/API/Instance.pm lib/Test2/API/Stack.pm lib/Test2/Event.pm lib/Test2/Event/Bail.pm lib/Test2/Event/Diag.pm lib/Test2/Event/Encoding.pm lib/Test2/Event/Exception.pm lib/Test2/Event/Fail.pm lib/Test2/Event/Generic.pm lib/Test2/Event/Note.pm lib/Test2/Event/Ok.pm lib/Test2/Event/Pass.pm lib/Test2/Event/Plan.pm lib/Test2/Event/Skip.pm lib/Test2/Event/Subtest.pm lib/Test2/Event/TAP/Version.pm lib/Test2/Event/Waiting.pm lib/Test2/EventFacet.pm lib/Test2/EventFacet/About.pm lib/Test2/EventFacet/Amnesty.pm lib/Test2/EventFacet/Assert.pm lib/Test2/EventFacet/Control.pm lib/Test2/EventFacet/Error.pm lib/Test2/EventFacet/Info.pm lib/Test2/EventFacet/Meta.pm lib/Test2/EventFacet/Parent.pm lib/Test2/EventFacet/Plan.pm lib/Test2/EventFacet/Render.pm lib/Test2/EventFacet/Trace.pm lib/Test2/Formatter.pm lib/Test2/Formatter/TAP.pm lib/Test2/Hub.pm lib/Test2/Hub/Interceptor.pm lib/Test2/Hub/Interceptor/Terminator.pm lib/Test2/Hub/Subtest.pm lib/Test2/IPC.pm lib/Test2/IPC/Driver.pm lib/Test2/IPC/Driver/Files.pm lib/Test2/Tools/Tiny.pm lib/Test2/Transition.pod lib/Test2/Util.pm lib/Test2/Util/ExternalMeta.pm lib/Test2/Util/Facets2Legacy.pm lib/Test2/Util/HashBase.pm lib/Test2/Util/Trace.pm lib/ok.pm t/00-report.t t/00compile.t t/HashBase.t t/Legacy/00test_harness_check.t t/Legacy/01-basic.t t/Legacy/478-cmp_ok_hash.t t/Legacy/BEGIN_require_ok.t t/Legacy/BEGIN_use_ok.t t/Legacy/Bugs/600.t t/Legacy/Bugs/629.t t/Legacy/Builder/Builder.t t/Legacy/Builder/carp.t t/Legacy/Builder/create.t t/Legacy/Builder/current_test.t t/Legacy/Builder/current_test_without_plan.t t/Legacy/Builder/details.t t/Legacy/Builder/done_testing.t t/Legacy/Builder/done_testing_double.t t/Legacy/Builder/done_testing_plan_mismatch.t t/Legacy/Builder/done_testing_with_no_plan.t t/Legacy/Builder/done_testing_with_number.t t/Legacy/Builder/done_testing_with_plan.t t/Legacy/Builder/fork_with_new_stdout.t t/Legacy/Builder/has_plan.t t/Legacy/Builder/has_plan2.t t/Legacy/Builder/is_fh.t t/Legacy/Builder/is_passing.t t/Legacy/Builder/maybe_regex.t t/Legacy/Builder/no_diag.t t/Legacy/Builder/no_ending.t t/Legacy/Builder/no_header.t t/Legacy/Builder/no_plan_at_all.t t/Legacy/Builder/ok_obj.t t/Legacy/Builder/output.t t/Legacy/Builder/reset.t t/Legacy/Builder/reset_outputs.t t/Legacy/Builder/try.t t/Legacy/More.t t/Legacy/Regression/637.t t/Legacy/Regression/683_thread_todo.t t/Legacy/Regression/6_cmp_ok.t t/Legacy/Regression/736_use_ok.t t/Legacy/Regression/789-read-only.t t/Legacy/Simple/load.t t/Legacy/Test2/Subtest.t t/Legacy/Tester/tbt_01basic.t t/Legacy/Tester/tbt_02fhrestore.t t/Legacy/Tester/tbt_03die.t t/Legacy/Tester/tbt_04line_num.t t/Legacy/Tester/tbt_05faildiag.t t/Legacy/Tester/tbt_06errormess.t t/Legacy/Tester/tbt_07args.t t/Legacy/Tester/tbt_08subtest.t t/Legacy/Tester/tbt_09do.t t/Legacy/Tester/tbt_09do_script.pl t/Legacy/auto.t t/Legacy/bad_plan.t t/Legacy/bail_out.t t/Legacy/buffer.t t/Legacy/c_flag.t t/Legacy/capture.t t/Legacy/check_tests.t t/Legacy/circular_data.t t/Legacy/cmp_ok.t t/Legacy/depth.t t/Legacy/diag.t t/Legacy/died.t t/Legacy/dont_overwrite_die_handler.t t/Legacy/eq_set.t t/Legacy/exit.t t/Legacy/explain.t t/Legacy/explain_err_vars.t t/Legacy/extra.t t/Legacy/extra_one.t t/Legacy/fail-like.t t/Legacy/fail-more.t t/Legacy/fail.t t/Legacy/fail_one.t t/Legacy/filehandles.t t/Legacy/fork.t t/Legacy/harness_active.t t/Legacy/import.t t/Legacy/is_deeply_dne_bug.t t/Legacy/is_deeply_fail.t t/Legacy/is_deeply_with_threads.t t/Legacy/missing.t t/Legacy/new_ok.t t/Legacy/no_log_results.t t/Legacy/no_plan.t t/Legacy/no_tests.t t/Legacy/note.t t/Legacy/overload.t t/Legacy/overload_threads.t t/Legacy/plan.t t/Legacy/plan_bad.t t/Legacy/plan_is_noplan.t t/Legacy/plan_no_plan.t t/Legacy/plan_shouldnt_import.t t/Legacy/plan_skip_all.t t/Legacy/require_ok.t t/Legacy/run_test.t t/Legacy/simple.t t/Legacy/skip.t t/Legacy/skipall.t t/Legacy/strays.t t/Legacy/subtest/args.t t/Legacy/subtest/bail_out.t t/Legacy/subtest/basic.t t/Legacy/subtest/callback.t t/Legacy/subtest/die.t t/Legacy/subtest/do.t t/Legacy/subtest/events.t t/Legacy/subtest/for_do_t.test t/Legacy/subtest/fork.t t/Legacy/subtest/implicit_done.t t/Legacy/subtest/line_numbers.t t/Legacy/subtest/plan.t t/Legacy/subtest/predicate.t t/Legacy/subtest/singleton.t t/Legacy/subtest/threads.t t/Legacy/subtest/todo.t t/Legacy/subtest/wstat.t t/Legacy/tbm_doesnt_set_exported_to.t t/Legacy/thread_taint.t t/Legacy/threads.t t/Legacy/todo.t t/Legacy/undef.t t/Legacy/use_ok.t t/Legacy/useing.t t/Legacy/utf8.t t/Legacy/versions.t t/Legacy_And_Test2/builder_loaded_late.t t/Legacy_And_Test2/diag_event_on_ok.t t/Legacy_And_Test2/hidden_warnings.t t/Legacy_And_Test2/preload_diag_note.t t/Test2/acceptance/try_it_done_testing.t t/Test2/acceptance/try_it_fork.t t/Test2/acceptance/try_it_no_plan.t t/Test2/acceptance/try_it_plan.t t/Test2/acceptance/try_it_skip.t t/Test2/acceptance/try_it_threads.t t/Test2/acceptance/try_it_todo.t t/Test2/behavior/Formatter.t t/Test2/behavior/Subtest_buffer_formatter.t t/Test2/behavior/Subtest_callback.t t/Test2/behavior/Subtest_events.t t/Test2/behavior/Subtest_plan.t t/Test2/behavior/Subtest_todo.t t/Test2/behavior/Taint.t t/Test2/behavior/disable_ipc_a.t t/Test2/behavior/disable_ipc_b.t t/Test2/behavior/disable_ipc_c.t t/Test2/behavior/disable_ipc_d.t t/Test2/behavior/err_var.t t/Test2/behavior/init_croak.t t/Test2/behavior/intercept.t t/Test2/behavior/ipc_wait_timeout.t t/Test2/behavior/nested_context_exception.t t/Test2/behavior/no_load_api.t t/Test2/behavior/run_subtest_inherit.t t/Test2/behavior/special_names.t t/Test2/behavior/subtest_bailout.t t/Test2/behavior/trace_signature.t t/Test2/legacy/TAP.t t/Test2/modules/API.t t/Test2/modules/API/Breakage.t t/Test2/modules/API/Context.t t/Test2/modules/API/Instance.t t/Test2/modules/API/Stack.t t/Test2/modules/Event.t t/Test2/modules/Event/Bail.t t/Test2/modules/Event/Diag.t t/Test2/modules/Event/Encoding.t t/Test2/modules/Event/Exception.t t/Test2/modules/Event/Fail.t t/Test2/modules/Event/Generic.t t/Test2/modules/Event/Note.t t/Test2/modules/Event/Ok.t t/Test2/modules/Event/Pass.t t/Test2/modules/Event/Plan.t t/Test2/modules/Event/Skip.t t/Test2/modules/Event/Subtest.t t/Test2/modules/Event/TAP/Version.t t/Test2/modules/Event/Waiting.t t/Test2/modules/EventFacet.t t/Test2/modules/EventFacet/About.t t/Test2/modules/EventFacet/Amnesty.t t/Test2/modules/EventFacet/Assert.t t/Test2/modules/EventFacet/Control.t t/Test2/modules/EventFacet/Error.t t/Test2/modules/EventFacet/Info.t t/Test2/modules/EventFacet/Meta.t t/Test2/modules/EventFacet/Parent.t t/Test2/modules/EventFacet/Plan.t t/Test2/modules/EventFacet/Trace.t t/Test2/modules/Formatter/TAP.t t/Test2/modules/Hub.t t/Test2/modules/Hub/Interceptor.t t/Test2/modules/Hub/Interceptor/Terminator.t t/Test2/modules/Hub/Subtest.t t/Test2/modules/IPC.t t/Test2/modules/IPC/Driver.t t/Test2/modules/IPC/Driver/Files.t t/Test2/modules/Tools/Tiny.t t/Test2/modules/Util.t t/Test2/modules/Util/ExternalMeta.t t/Test2/modules/Util/Facets2Legacy.t t/Test2/modules/Util/Trace.t t/Test2/regression/693_ipc_ordering.t t/Test2/regression/746-forking-subtest.t t/Test2/regression/gh_16.t t/Test2/regression/ipc_files_abort_exit.t t/lib/Dev/Null.pm t/lib/Dummy.pm t/lib/MyOverload.pm t/lib/MyTest.pm t/lib/NoExporter.pm t/lib/SigDie.pm t/lib/SkipAll.pm t/lib/SmallTest.pm t/lib/Test/Builder/NoOutput.pm t/lib/Test/Simple/Catch.pm t/lib/Test/Simple/sample_tests/death.plx t/lib/Test/Simple/sample_tests/death_in_eval.plx t/lib/Test/Simple/sample_tests/death_with_handler.plx t/lib/Test/Simple/sample_tests/exit.plx t/lib/Test/Simple/sample_tests/extras.plx t/lib/Test/Simple/sample_tests/five_fail.plx t/lib/Test/Simple/sample_tests/last_minute_death.plx t/lib/Test/Simple/sample_tests/missing_done_testing.plx t/lib/Test/Simple/sample_tests/one_fail.plx t/lib/Test/Simple/sample_tests/one_fail_without_plan.plx t/lib/Test/Simple/sample_tests/pre_plan_death.plx t/lib/Test/Simple/sample_tests/require.plx t/lib/Test/Simple/sample_tests/success.plx t/lib/Test/Simple/sample_tests/too_few.plx t/lib/Test/Simple/sample_tests/too_few_fail.plx t/lib/Test/Simple/sample_tests/two_fail.plx t/lib/TieOut.pm t/regression/642_persistent_end.t t/regression/662-tbt-no-plan.t t/regression/684-nested_todo_diag.t t/regression/694_note_diag_return_values.t t/regression/696-intercept_skip_all.t t/regression/721-nested-streamed-subtest.t t/regression/757-reset_in_subtest.t t/regression/buffered_subtest_plan_buffered.t t/regression/builder_does_not_init.t t/regression/errors_facet.t t/regression/inherit_trace.t t/regression/no_name_in_subtest.t t/regression/todo_and_facets.t t/zzz-check-breaks.t xt/author/pod-spell.t xt/author/pod-syntax.t Test-Simple-1.302125/Changes0000644000175000017500000023137413243466361015352 0ustar exodistexodist1.302125 2018-02-21 23:10:39-08:00 America/Los_Angeles - No changes since trial 1.302124 2018-02-13 22:02:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix a test to skip without threads 1.302123 2018-02-13 21:39:31-08:00 America/Los_Angeles (TRIAL RELEASE) - Make it possible to disable IPC 1.302122 2018-02-05 08:13:56-08:00 America/Los_Angeles - Add 'mode' ro render facet 1.302121 2018-02-04 13:27:41-08:00 America/Los_Angeles - Update Copyright - Add 'render' facet 1.302120 2017-11-29 18:49:15-08:00 America/Los_Angeles - No Changes since last trial 1.302119 2017-11-28 15:35:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix IPC reload bug 1.302118 2017-11-28 10:14:12-08:00 America/Los_Angeles - No Changes since last trial 1.302117 2017-11-27 14:10:53-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix event Out of Order bug - Add driver_abort() hook for IPC Drivers 1.302116 2017-11-23 15:14:26-08:00 America/Los_Angeles (TRIAL RELEASE) - add better interface for ipc_wait 1.302115 2017-11-22 21:14:55-08:00 America/Los_Angeles (TRIAL RELEASE) - ipc_wait now reports exit and signal values 1.302114 2017-11-21 15:28:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Added pre-subtest hook to Test2::API (#801 from dakkar) 1.302113 2017-11-20 14:04:16-08:00 America/Los_Angeles - Fix SIGPIPE in IPC test - Mark a test as usually AUTHOR_TESTING only 1.302112 2017-11-20 06:43:16-08:00 America/Los_Angeles - Fix test on threaded 5.8 1.302111 2017-11-18 09:54:33-08:00 America/Los_Angeles - Remove debugging from previous trial 1.302110 2017-11-17 09:47:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix test breakage (from previous trial) on older perls 1.302109 2017-11-17 09:35:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix some fragile tests - Add debugging to API/Instance.t for a cpan-testers failure 1.302108 2017-11-16 14:19:24-08:00 America/Los_Angeles (TRIAL RELEASE) - Apply p5p test patch from Craig A. Berry 1.302107 2017-11-16 07:44:59-08:00 America/Los_Angeles (TRIAL RELEASE) - Allow regexp in Test::Tester 1.302106 2017-10-20 20:42:43-07:00 America/Los_Angeles - Make version number in HashBase sane. 1.302105 2017-10-20 07:09:45-07:00 America/Los_Angeles - No changes since last trial 1.302104 2017-10-19 11:39:01-07:00 America/Los_Angeles (TRIAL RELEASE) - Combine multiple diags into one event 1.302103 2017-10-15 10:11:29-07:00 America/Los_Angeles - No changes since last TRIAL 1.302102 2017-10-14 20:05:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix some TODO edge cases that were not previously accounted for 1.302101 2017-10-12 07:43:16-07:00 America/Los_Angeles - Bump Test::Builder::IO::Scalar version for core 1.302100 2017-10-10 14:30:18-07:00 America/Los_Angeles - No changes since last TRIAL 1.302099 2017-10-10 09:29:40-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix run_subtest inherit_trace option 1.302098 2017-10-03 06:13:49-07:00 America/Los_Angeles - Add docs for test2_stdout and test2_stderr - Fix 5.6 support 1.302097 2017-10-02 19:35:08-07:00 America/Los_Angeles - Fix hub->process bug that could let an error pass - Fix #789 (Modification of read only value) - Fix typo in Test::Builder when looking for IPC (#777) - Fix #791, clone_io broke on scalar io layer - Fix #790 and #756, Exception event stingify exception - Localize $^E in context (#780) - Fix test that failed in verbose mode (#770) 1.302096 2017-09-10 21:16:18-07:00 America/Los_Angeles - Fix to work with subref-in-stash optimisation (Father C.) 1.302095 2017-08-31 20:35:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Make several tests work with preload 1.302094 2017-08-30 21:27:23-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix Test::Builder in a preload scenario 1.302093 2017-08-29 21:05:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure Test::Builder does not initialize Test2 too soon. 1.302092 2017-08-28 21:30:06-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix bug in Facets for TodoDiag - Add API command to reset after a fork - Add 'important' flag to info event facet 1.302091 2017-08-08 19:50:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'new_root' constructor for formatters - Add intercept_deep() to the API - Fix bug in Version event - Add 'number' attribute to assertion facet 1.302090 2017-07-09 21:10:08-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that unintentionally required Test2::Suite 1.302089 2017-07-09 20:51:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix plan in buffered subtest so that the facts say it is buffered 1.302088 2017-06-28 21:55:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix tests on perl 5.25+ with newer Data::Dumper 1.302087 2017-06-26 20:32:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Introduce 'Facets' for events - Performance enhancements - Upgrade inline HashBase - Move Test2::Util::Trace to Test2::EventFacet::Trace - Track hub id in Trace - Remove Info event - Add Pass and Fail events - Remove Event JSON interface 1.302086 2017-06-20 10:43:13-07:00 America/Los_Angeles - Make it possible to turn off result logging in Test::Builder 1.302085 2017-05-01 19:24:37-07:00 America/Los_Angeles - No Changes since last TRIAL 1.302084 2017-04-29 20:42:48-07:00 America/Los_Angeles (TRIAL RELEASE) - Better IO management - Allow access to the STDERR/STDOUT Test2::API uses - Formatters should use the Test2::API handles 1.302083 2017-04-14 10:55:26-07:00 America/Los_Angeles - Update some breakage info for Test::More::Prefix and Test::DBIx::Class::Schema 1.302082 2017-04-11 12:56:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that incorrectly called private function as method 1.302081 2017-04-06 10:39:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix threads timeout for older perls (as best we can) 1.302080 2017-04-04 20:24:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Timeout when waiting for child procs and threads (#765) - Fix SIGSYS localization issue (#758) - Fix outdated docs (#759, #754) - Fix bail-out in buffered subtest (#747) 1.302079 2017-04-03 12:12:02-07:00 America/Los_Angeles (TRIAL RELEASE) - Fixes for '. in @INC' changes (#768) 1.302078 2017-03-01 15:24:12-08:00 America/Los_Angeles - No changes since last trial 1.302077 2017-02-19 14:34:30-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix #762, newlines for todo subtest - Revisit #637, fix rare race condition it created 1.302076 2017-02-01 19:38:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix crash when TB->reset used inside subtest 1.302075 2017-01-10 19:39:28-08:00 America/Los_Angeles - No changes, just marking a stable release 1.302074 2017-01-08 11:41:44-08:00 America/Los_Angeles (TRIAL RELEASE) - Add 'cid' to trace - Add signatures to trace - Add related() to events - Now it is possible to check if events are related - Add 'no_fork' option to run_subtest() 1.302073 2016-12-18 23:02:54-08:00 America/Los_Angeles - No changes from last trial 1.302072 2016-12-18 01:08:12-08:00 America/Los_Angeles (TRIAL RELEASE) - Expose tools.pl as Test2::Tools::Tiny 1.302071 2016-12-17 12:08:29-08:00 America/Los_Angeles - No changes since last trial release 1.302070 2016-12-14 21:32:47-08:00 America/Los_Angeles (TRIAL RELEASE) - Added two new event classes, Test2::Event::Encoding and Test2::Event::TAP::Version. These are primarily being added for the benefit of Test2::Harness now, but they could be useful for other Test2 event consumer tools in the future. Implemented by Dave Rolsky (#743). 1.302069 2016-12-12 15:03:04-08:00 America/Los_Angeles (TRIAL RELEASE) - Generate HashBase from Object::HashBase which has been split out - When a subtest is marked as todo, all of its contained Ok and Subtest events are now updated so that they return true for $e->effective_pass. Implemented by Dave Rolsky. (#742) 1.302068 2016-12-03 13:50:01-08:00 America/Los_Angeles (TRIAL RELEASE) - Add TO_JSON and from_json methods to Test2::Event and Test2::Trace::Util to faciliate transferring event data between processes. Implemented by Dave Rolsky. (#741). 1.302067 2016-11-23 07:37:56-08:00 America/Los_Angeles - Fix context test for recent blead. 1.302066 2016-11-08 07:58:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Handle cases where SysV IPC can be available but not enabled - Import 'context' into Test2::IPC, it is used by 'cull' - Propogate warnings settings to use_ok (#736) 1.302065 2016-10-30 11:54:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Set the TEST_ACTIVE env var to true - Set the TEST2_ACTIVE env var to true - Fix the oldest bug still in the bug list (#6) This fixes cmp_ok output is some confusing cases - Update travis config - Add missing author deps - Fix handling of negative pid's on windows - Add can() to Test::Tester::Delegate (despite deprecation) - Fix some minor test issues 1.302064 2016-10-24 21:03:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Repo management improvements - Better handling of info vs diag in ->send_event - Fix test that used 'parent' - Better handling of non-bumping failures (#728) 1.302063 2016-10-23 21:31:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix double release when 'throw' is used in context_do() 1.302062 2016-10-20 06:16:08-07:00 America/Los_Angeles - No changes from last trial 1.302061 2016-09-30 14:49:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Removed a warning when using a non-TAP formatter with Test::Builder about the formatter not "no_header" and "no_diag". This happened even if the alternative formatter class implemented these attributes. - When finalize is called on a formatter, it now receives one more argument, a boolean indicating whether or not the call is for a subtest or not. 1.302060 2016-09-25 12:46:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Formatters now have terminate() and finalize() methods. These are called when there is a skip_all or bail event (terminate) or when a test suite is exiting normally (finalize). This allows formatters to finalize their output, which is important for any sort of document-oriented format (as opposed to a stream format like TAP). (#723) 1.302059 2016-09-25 12:32:21-07:00 America/Los_Angeles - No changes from last trial 1.302058 2016-09-21 10:46:13-07:00 America/Los_Angeles (TRIAL RELEASE) - Mask warning when comparing $@ in Test2::API::Context 1.302057 2016-09-18 12:12:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Doc fixes - Win32 color support in Test::Builder::Tester - Support v-strings in is_deeply - A streamed subtest run inside a buffered subtest will be automatically converted to a buffered subtest. Otherwise the output from inside the subtest is lost entirely. (#721) 1.302056 2016-09-12 09:03:49-07:00 America/Los_Angeles - Minor typo fix - No logic chnges since last trial 1.302055 2016-08-30 12:13:32-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix special case of ok line ending in \ - Improve a test that captures STDERR/STDOUT (Thanks HAARG) 1.302054 2016-08-20 16:21:44-07:00 America/Los_Angeles (TRIAL RELEASE) - Allow '#' and '\n' in ok names 1.302053 2016-08-17 21:22:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix skip_all in require in intercept (#696) - Documentation of what is better in Test2 (#663) - Document Test::Builder::Tester plan limitations - Document limitations in is_deeply (#595) - Better documentation of done_testing purpose (#151) - Make ctx->send_event detect termination events (#707) 1.302052 2016-08-13 14:34:07-07:00 America/Los_Angeles - No Changes from last trial 1.302051 2016-08-11 20:26:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix setting hub when getting context 1.302050 2016-08-10 22:12:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Add contact info to main doc and readme 1.302049 2016-07-28 07:03:31-07:00 America/Los_Angeles - No Changes from last trial 1.302048 2016-07-27 07:42:14-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'active' attribute to hub 1.302047 2016-07-22 22:36:29-07:00 America/Los_Angeles - No Changes from last trial 1.302046 2016-07-19 06:58:43-07:00 America/Los_Angeles (TRIAL RELEASE) - Restore traditional note/diag return values (#694) 1.302045 2016-07-18 09:05:15-07:00 America/Los_Angeles - No changes from last TRIAL release 1.302044 2016-07-13 17:56:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that segv'd on older perls 1.302043 2016-07-12 09:37:31-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix TODO in mixed T2/TB subtests 1.302042 2016-07-11 20:30:35-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix IPC event ordering bug 1.302041 2016-07-09 17:01:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Work around IPC bug on windows 1.302040 2016-07-09 16:55:00-07:00 America/Los_Angeles - No changes from last trial 1.302039 2016-07-07 22:01:02-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Info event for better diagnostics 1.302038 2016-07-05 07:00:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix broken MANIFEST.SKIP entries (#689) 1.302037 2016-07-04 10:09:00-07:00 America/Los_Angeles - No changes from trial 1.302036 2016-07-03 11:52:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Restore PerlIO layer cloning on STDERR and STDOUT 1.302035 2016-06-27 08:55:55-07:00 America/Los_Angeles - No changes since TRIAL release 1.302034 2016-06-25 13:51:00-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix some breakage info (Thanks Dolman!) - POD Fixes (Thanks cpansprout!) 1.302033 2016-06-24 05:56:54-07:00 America/Los_Angeles - No changes from last trial release 1.302032 2016-06-22 11:30:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix nested TODO handling of Diags (#684) 1.302031 2016-06-21 09:51:27-07:00 America/Los_Angeles - Remove carp from dep list #682 1.302030 2016-06-18 19:02:55-07:00 America/Los_Angeles - No changes from last DEV release 1.302029 2016-06-17 06:56:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Properly skip thread test when threads are broken 1.302028 2016-06-16 19:21:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'inherit_trace' param to run_subtest 1.302027 2016-06-15 09:42:32-07:00 America/Los_Angeles (TRIAL RELEASE) - use pre_filter instead of filter for TODO in Test::Builder (Fix $683) - Fix typos in transitions doc (#681) 1.302026 2016-06-07 07:53:30-07:00 America/Los_Angeles - No Changes from 1.302025-TRIAL 1.302025 2016-06-06 22:38:12-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure enabling culling/shm sets pid and tid (Fix #679) 1.302024 2016-06-02 20:27:35-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Generic event type 1.302023 2016-06-02 08:09:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Do not fail if Test2::API::Breakage cannot load (rare 5.10.0 issue) - Potential fix for t/Legacy/Regression/637.t - Make t/Legacy/Regression/637.t AUTHOR_TESTING for now 1.302022 2016-05-28 17:53:11-07:00 America/Los_Angeles - Improve thread checks to better detect broken 5.10 builds - Use thread checks to skip/run t/Legacy/Regression/637.t 1.302021 2016-05-20 21:47:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Files.t should warn, not die, if it cannot remove its temp dir. - VMS fixes for Files.t and IPC system 1.302020 2016-05-18 11:54:15-07:00 America/Los_Angeles (TRIAL RELEASE) - Many micro-opts from Graham Knop (haarg) - Spelling fixes and tests from Karen Etheridge (ether) - Fix leaky File.t file so that tmp doesn't fill up - Move some modules out of the known broken list in xt tests - Add Test2 based tools to downstream testing - Change when PID/TID are stashed (for forkprove) 1.302019 2016-05-18 08:16:39-07:00 America/Los_Angeles - POD Spelling fixes 1.302018 2016-05-14 09:08:05-07:00 America/Los_Angeles (TRIAL RELEASE) - Handle Test::Builder::Exception properly - Silence noisy STDERR in test suite 1.302017 2016-05-13 08:09:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix util.t win32 bug 1.302016 2016-05-12 19:43:38-07:00 America/Los_Angeles (TRIAL RELEASE) - Block signals in critical IPC section (Fix #661 and #668) - Merge Examples and examples into one dir (#660) - Documentation and typo fixes - Make Test2::Util::get_tid have a consistent prototype (#665) - Make TB->no_plan a no-op if a plan is set 1.302015 2016-05-09 07:46:54-07:00 America/Los_Angeles - Add Test::Alien to breakage info - Add Device::Chip to breakage info - Add subtest outdent to transition.pod 1.302014_010 2016-05-03 12:09:14-07:00 America/Los_Angeles (TRIAL RELEASE) - RC10 - Update x-breaks, Breakage.pm, and Transition.POD - Fix shared memory leak - Fix typos and clarify docs. 1.302014_009 2016-04-27 10:05:18-07:00 America/Los_Angeles (TRIAL RELEASE) - RC9 - No logic changes - Update x-breaks stuff - Update email addresses 1.302014_008 2016-04-26 11:40:40-07:00 America/Los_Angeles (TRIAL RELEASE) - RC8 - Fix bug when using defined, but empty (or space) as a test name in a subtest - Better notificatons for late Test::Builder load - Recommend Test2::Transition if you have outdated modules - Document Test::Builder::TodoDiag and Test::Builder::Formatter 1.302014_007 2016-04-24 13:09:03-07:00 America/Los_Angeles (TRIAL RELEASE) - RC7 - Fix #642 - Persistent environments need to have ENDING flag cleared 1.302014_006 2016-04-24 02:31:13-07:00 America/Los_Angeles (TRIAL RELEASE) - RC6 - Remove reduntant and problematic parts of 00-report.t - No changes to actual code, just a test that provides diags 1.302014_005 2016-04-24 01:55:55-07:00 America/Los_Angeles (TRIAL RELEASE) - RC5 - Prevent the breakage reporter from being a test failure - No changes to actual code, just a test that provides diags 1.302014_004 2016-04-23 16:21:34-07:00 America/Los_Angeles (TRIAL RELEASE) - RC4 - Update breakage info - Fix IPC files driver to use the most significant data in the shm (needs test) 1.302014_003 2016-04-23 03:20:36-07:00 America/Los_Angeles (TRIAL RELEASE) - RC3 - Localize $@ and $! when loading Data::Dumper in explain() 1.302014_002 2016-04-22 14:54:51-07:00 America/Los_Angeles (TRIAL RELEASE) - RC2 - Restore X-Breaks meta info - Keep dist.ini in the tarball 1.302014_001 2016-04-22 04:01:50-07:00 America/Los_Angeles (TRIAL RELEASE) - RC1 - Merge Test2 into the Test-Simple dist - Remove experimental status - Update copyright dates - Better error messages when using Carp in Hashbase init() - Document 2 methods on Events - Fix Test2 #17 (typo fix in docs) - Report version mismatches between Test::Builder and Test2 - Update transition docs - Breakage library and warnings ***************************************************************************** * * * BELOW THIS POINT ARE THE SEPERATE CHANGELOGS FOR Test-Simple, Test2, AND * * Test-Stream. * * * ***************************************************************************** Test-Simple 1.302013_019 2016-04-13 20:23:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Expand no_numbers support to custom formatters Test-Simple 1.302013_018 2016-04-07 21:23:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Support Test2 using an alternative formatter Test-Simple 1.302013_017 2016-04-05 11:13:50-07:00 America/Los_Angeles (TRIAL RELEASE) - Support subtest identification for events - Bump minimum Test2 version Test-Simple 1.302013_016 2016-04-04 21:33:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Support some newer event features from Test2 - Bump minimum Test2 version Test-Simple 1.302013_015 2016-03-29 09:24:10-07:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version to protect from segv Test-Simple 1.302013_014 2016-03-08 10:00:50-08:00 America/Los_Angeles (TRIAL RELEASE) - Skip test added in last release when threading is not avilable Test-Simple 1.302013_013 2016-03-08 09:19:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Test::Builder->reset now resets hub's idea of root pid/tid (#637) Test-Simple 1.302013_012 2016-01-28 20:38:16-08:00 America/Los_Angeles (TRIAL RELEASE) - $Level effects all contexts once Test::Builder is loaded - Requires Test2 0.000023 Test-Simple 1.302013_011 2016-01-14 21:55:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Performance enhancements Test-Simple 1.302013_010 2016-01-12 05:57:43-08:00 America/Los_Angeles (TRIAL RELEASE) - Changes needed for Test2 0.000018 Test-Simple 1.302013_009 2016-01-11 16:35:57-08:00 America/Los_Angeles (TRIAL RELEASE) - Make skip work without a count w/ done_testing (#629) - Require newer Test2 that fixes $! squashing (#628) Test-Simple 1.302013_008 2016-01-10 13:21:02-08:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version requirement (to fix downstream) Test-Simple 1.302013_007 2016-01-07 19:30:04-08:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version requirement Test-Simple 1.302013_006 2016-01-06 11:21:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Update for Test2 0.000013 - Delay loading Data::Dumper - Test2::API::test2_no_wait(1) when threads/forking are on - Fix Test::Tester to use context - More downstream dists for testing Test-Simple 1.302013_005 2015-12-29 13:01:32-08:00 America/Los_Angeles (TRIAL RELEASE) - Updates for Test2 0.000012 - Helper for Test::SharedFork Test-Simple 1.302013_004 2015-12-28 13:12:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix diag/note bugs from refactor Test-Simple 1.302013_003 2015-12-22 09:41:46-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix bug in details() structure for subtests when the parent is todo Test-Simple 1.302013_002 2015-12-21 13:21:51-08:00 America/Los_Angeles (TRIAL RELEASE) - Updates for Test2 0.000010 Test-Simple 1.302013_001 2015-12-21 10:07:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Switch to using Test2 under the hood - Use Dist::Zilla for releases - Reformat Changes file Test-Simple 1.302012_004 2015-Nov-16 07:45:11-08:00 PST * Fix #600 - done_testing($count) Test-Simple 1.302012_003 2015-Oct-27 00:02:44-08:00 PST * Fix typo that called wrong 'try' Test-Simple 1.302012_002 2015-Oct-02 21:57:19-08:00 PST * Add version eval to several modules (#605) Test-Simple 1.302012_001 2015-Oct-01 15:47:39-08:00 PST * Support for Test::Stream 1.302012 Test-Simple 1.302010_001 2015-Sep-29 21:18:38-08:00 PST * Support for Test::Stream 1.302010 * Some upstream package names changed * Test::Stream's interface changed, tests needed to change too. Test-Simple 1.302007_004 2015-Jul-27 21:13:39-08:00 PST * Work around perlbug 125702 Test-Simple 1.302007_003 2015-Jul-24 08:34:46-08:00 PST * Remove singleton from closure Test-Simple 1.302007_002 2015-Jul-18 17:38:26-08:00 PST * Fix subtest + Test::Stream::Tester Test-Simple 1.302007_001 2015-Jun-24 08:06:00-08:00 PST * Tests no longer copy thread/fork checks * Bump minimum Test::Stream version Test-Simple 1.302004_001 2015-Jun-17 08:33:00-08:00 PST * Update for newer Test-Stream with XS support * Use 'fudge' in Test::Stream instead of doing level adjustments here * Fix minor POD encoding issue #593 * Some performance enhancements in T::B->ok Test-Simple 1.302003_001 2015-Jan-06 21:52:00-08:00 PST * Convert internals to use Test-Stream * Optimizations for performance * Note this is a completely new branch off of legacy/master, not taken from the old stream branches Test-Simple 1.001014 2014-Dec-28 08:31:00-08:00 PST * Write a test to ensure this changes file gets updated * Update changes file for 1.001013 Test-Simple 1.001013 2014-Dec-28 08:00:00-08:00 PST * Fix a unit test that broke on some platforms with spaces in the $^X path Test-Simple 1.001012 2014-Dec-23 07:39:00-08:00 PST * Move test that was dropped in the wrong directory Test-Simple 1.001011 2014-Dec-20 09:08:00-08:00 PST * Remove POD Coverage test Test-Simple 1.001010 2014-Dec-19 20:16:00-08:00 PST * Fix windows test bug #491 * Integrate Test::Tester and Test::use::ok for easier downgrade from trial Test-Simple 1.001009 2014-Nov-2 22:31:08-08:00 PST * Fix bug in cmp_ok Test-Simple 1.001008 2014-Oct-15 20:10:22-08:00 PST * Updated Changes file Test-Simple 1.001007 2014-Oct-15 16:37:11-08:00 PST * Fix subtest name when skip_all is used Test-Simple 1.001006 2014-Sep-2 14:39:05-08:00 PST * Reverted change that is now part of alpha branch Test-Simple 1.001005 2014-Sep-2 19:47:19-08:00 JST * Changed install path for perl 5.12 or higher. Test-Simple 1.001004_003 2014-May-17 13:43-08:00 PST * Another Minor doc fix to solve test bug * Fix #399, conflict with strawberry-portable Test-Simple 1.001004_002 2014-May-17 13:43-08:00 PST * Minor doc fix to solve test bug Test-Simple 1.001004_001 2014-May-10 08:39-08:00 PST * Doc updates * Subtests accept args * Outdent subtest diag Test-Simple 1.001003 2014-Mar-21 21:12-08:00 PST * Doc updates for maintainer change Test-Simple 1.001002 2013-Nov-4 15:13-08:00 EST * no changes since 0.99 Test-Simple 1.001001_001 2013-Oct-30 20:47-08:00 EDT * no code changes, just a new version number with more room to grow Test-Simple 0.99 2013-Oct-29 13:21:03-08:00 EDT * restore ability to use regex with test_err and test_out (Zefram) [rt.cpan.org #89655] [github #389] [github #387] Test-Simple 0.99 2013-Oct-12 15:05-08:00 EDT * no changes since 0.98_06 Test-Simple 0.98_06 2013-Sep-27 10:11-08:00 EDT Bug Fixes * Fix precedence error with (return ... and ...) (nthykier) [github #385] Test-Simple 0.98_05 2013-Apr-23 17:33-08:00 PDT Doc Changes * Add a shorter work around for the UTF-8 output problem. (Michael G Schwern) Bug Fixes * Test::Builder::Tester now works with subtests. (Michael G Schwern) [github 350] * Fix test_fail() inside a do statement. (nnutter) [github #369] New Features * A subtest will put its name at the front of its results to make subtests easier to read. [github #290] [github #364] (Brendan Byrd) Feature Changes * like() and unlike() no longer warn about undef. [github #335] (Michael G Schwern) Test-Simple 0.98_04 2013-Apr-14 10:54-08:00 BST Distribution Changes * Scalar::Util 1.13 (ships with Perl 5.8.1) is now required. (Michael G Schwern) Feature Changes * The default name and diagnostics for isa_ok() and new_ok() have changed. (Michael G Schwern) Docs Fixes * Added a COMPATIBILITY section so users know what major features were added with what version of Test::More or perl. [github 343] [github 344] (pdl) * Fix the ok() example with grep(). (derek.mead@gmail.com) Bug Fixes * A test with no plan and missing done_testing() now exits with non-zero. [github #341] (tokuhirom) * isa_ok() tests were broken in 5.17 because of a change in method resolution. [github #353] (Michael G Schwern) Test-Simple 0.98_03 2012-Jun-21 13:04-08:00 PDT New Features * cmp_ok() will error when used with something which is not a comparison operator, including =, += and the like. [github 141] (Matthew Horsfall) Bug Fixes * use_ok() was calling class->import without quoting which could cause problems if "class" is also a function. Doc Fixes * use_ok() has been discouraged and de-emphasized as a general replacement for `use` in tests. [github #288] * $thing is now $this in the docs to avoid confusing users of other languages. [Karen Etheridge] Incompatible Changes With Previous Alphas (0.98_01) * use_ok() will no longer apply lexical pragams. The incompatibilities and extra complexity is not worth the marginal use. [github #287] Test-Simple 0.98_02 2011-Nov-24 01:13-08:00 PST Bug Fixes * use_ok() in 0.98_01 was leaking pragmas from inside Test::More. This looked like Test::More was forcing strict. [rt.cpan.org 67538] (Father Chrysostomos) Test-Simple 0.98_01 2011-Nov-8 17:07-08:00 PST Bug Fixes * BAIL_OUT works inside a subtest. (Larry Leszczynski) [github #138] * subtests now work with threads turned on. [github #145] Feature Changes * use_ok() will now apply lexical effects. [rt.cpan.org 67538] (Father Chrysostomos) Misc * Test::More, Test::Simple and Test::Builder::Module now require a minimum version of Test::Builder. This avoids Test::More and Test::Builder from getting out of sync. [github #89] Test-Simple 0.98 2011-Fev-23 14:38:02 +1100 Bug Fixes * subtest() should not fail if $? is non-zero. (Aaron Crane) Docs * The behavior of is() and undef has been documented. (Pedro Melo) Test-Simple 0.97_01 2010-Aug-27 22:50-08:00 PDT Test Fixes * Adapted the tests for the new Perl 5.14 regex stringification. (Karl Williamson) [github 44] Doc Fixes * Document how to test "use Foo ()". (Todd Rinaldo) [github 41] Feature Changes * subtest() no longer has a prototype. It was just getting in the way. [rt.cpan.org 54239] * The filehandles used by default will now inherit any filehandle disciplines from STDOUT and STDERR IF AND ONLY IF they were applied before Test::Builder is loaded. More later. [rt.cpan.org 46542] Test-Simple 0.96 2010-Aug-10 21:13-08:00 PDT Bug Fixes * You can call done_testing() again after reset() [googlecode 59] Other * Bug tracker moved to github Test-Simple 0.95_02 2010-May-19 15:46-08:00 PDT Bug Fixes * Correct various typos and spelling errors (Nick Cleaton) * Fix alignment of indented multi-line diagnostics from subtests (Nick Cleaton) * Fix incorrect operation when subtest called from within a todo block (Nick Cleaton) * Avoid spurious output after a fork within a subtest (Nick Cleaton) Test-Simple 0.95_01 2010-Mar-3 15:36-08:00 PST Bug Fixes * is_deeply() didn't see a difference in regexes [rt.cpan.org 53469] * Test::Builder::Tester now sets $tb->todo_output to the output handle and not the error handle (to be in accordance with the default behaviour of Test::Builder and allow for testing TODO test behaviour). * Fixed file/line in failing subtest() diagnostics. (Nick Cleaton) * Protect against subtests setting $Level (Nick Cleaton) New Features * subtests without a 'plan' or 'no_plan' have an implicit 'done_testing()' added to them. * is_deeply() performance boost for large structures consisting of mostly non-refs (Nick Cleaton) Feature Changes * is() and others will no longer stringify its arguments before comparing. Overloaded objects will make use of their eq overload rather than their "" overload. This can break tests of impolitely string overloaded objects. DateTime prior to 0.54 is the biggest example. Test-Simple 0.94 2009-Sep-2 11:17-08:00 PDT Releasing 0.93_01 as stable. Test-Simple 0.93_01 2009-Jul-20 09:51-08:00 PDT Bug Fixes * Make sure that subtest works with Test:: modules which call Test::Builder->new at the top of their code. (Ovid) Other * subtest() returns! Test-Simple 0.92 2009-Jul-3 11:08-08:00 PDT Test Fixes * Silence noise on VMS in exit.t (Craig Berry) * Skip Builder/fork_with_new_stdout.t on systems without fork (Craig Berry) Test-Simple 0.90 2009-Jul-2 13:18-08:00 PDT Docs * Note the IO::Stringy license in our copy of it. [test-more.googlecode.com 47] Other * This is a stable release for 5.10.1. It does not include the subtest() work in 0.89_01. Test-Simple 0.89_01 2009-Jun-23 15:13-08:00 EDT New Features * subtest() allows you to run more tests in their own plan. (Thanks Ovid!) * Test::Builder->is_passing() will let you check if the test is currently passing. Docs * Finally added a note about the "Wide character in print" warning and how to work around it. Test Fixes * Small fixes for integration with the Perl core [bleadperl eaa0815147e13cd4ab5b3d6ca8f26544a9f0c3b4] * exit code tests could be effected by errno when PERLIO=stdio [bleadperl c76230386fc5e6fba9fdbeab473abbf4f4adcbe3] Test-Simple 0.88 2009-May-30 12:31-08:00 PDT Turing 0.87_03 into a stable release. Test-Simple 0.87_03 2009-May-24 13:41-08:00 PDT New Features * isa_ok() now works on classes. (Peter Scott) Test-Simple 0.87_02 2009-Apr-11 12:54-08:00 PDT Test Fixes * Some filesystems don't like it when you open a file for writing multiple times. Fixes t/Builder/reset.t. [rt.cpan.org 17298] * Check how an operating system is going to map exit codes. Some OS' will map them... sometimes. [rt.cpan.org 42148] * Fix Test::Builder::NoOutput on 5.6.2. Test-Simple 0.87_01 2009-Mar-29 09:56-08:00 BST New Features * done_testing() allows you to declare that you have finished running tests, and how many you ran. It is a safer no_plan and effectively replaces it. * output() now supports scalar references. Feature Changes * You can now run a test without first declaring a plan. This allows done_testing() to work. * You can now call current_test() without first declaring a plan. Bug Fixes * skip_all() with no reason would output "1..0" which is invalid TAP. It will now always include the SKIP directive. Other * Repository moved to github. Test-Simple 0.86 2008-Nov-9 01:09-08:00 PST Same as 0.85_01 Test-Simple 0.85_01 2008-Oct-23 18:57-08:00 PDT New Features * cmp_ok() now displays the error if the comparison throws one. For example, broken overloaded objects. Bug Fixes * cmp_ok() no longer stringifies or numifies its arguments before comparing. This makes cmp_ok() properly test overloaded ops. [rt.cpan.org 24186] [code.google.com 16] * diag() properly escapes blank lines. Feature Changes * cmp_ok() now reports warnings and errors as coming from inside cmp_ok, as well as reporting the caller's file and line. This let's the user know where cmp_ok() was called from while reminding them that it is being run in a different context. Other * Dependency on ExtUtils::MakeMaker 6.27 only on Windows otherwise the nested tests won't run. Test-Simple 0.84 2008-Oct-15 09:06-08:00 EDT Other * 0.82 accidentally shipped with experimental Mouse dependency. Test-Simple 0.82 2008-Oct-14 23:06-08:00 EDT Bug Fixes - 0.81_01 broke $TODO such that $TODO = '' was considered todo. Test-Simple 0.81_02 2008-Sep-9 04:35-08:00 PDT New Features * Test::Builder->reset_outputs() to reset all the output methods back to their defaults. Bug Fixes - Fixed the file and line number reported by like when it gets a bad regex. Feature Changes - Now preserves the tests' exit code if it exits abnormally, rather than setting it to 255. - Changed the "Looks like your test died" message to "Looks like your test exited with $exit_code" - no_plan now only warns if given an argument. There were a lot of people doing that, and it's a sensible mistake. [test-more.googlecode.com 13] Test-Simple 0.81_01 2008-Sep-6 15:13-08:00 PDT New Features * Adam Kennedy bribed me to add new_ok(). The price was one DEFCON license key. [rt.cpan.org 8891] * TODO tests can now start and end with 'todo_start' and 'todo_end' Test::Builder methods. [rt.cpan.org 38018] * Added Test::Builder->in_todo() for a safe way to check if a test is inside a TODO block. This allows TODO tests with no reason. * Added note() and explain() to both Test::More and Test::Builder. [rt.cpan.org 14764] [test-more.googlecode.com 3] Feature Changes * Changed the message for extra tests run to show the number of tests run rather than the number extra to avoid the user having to do mental math. [rt.cpan.org 7022] Bug fixes - using a relative path to perl broke tests [rt.cpan.org 34050] - use_ok() broke $SIG{__DIE__} in the used module [rt.cpan.org 34065] - diagnostics for isnt() were confusing on failure [rt.cpan.org 33642] - warnings when MakeMaker's version contained _ [rt.cpan.org 33626] - add explicit test that non-integer plans die correctly [rt.cpan.org 28836] (Thanks to Hans Dieter Pearcey [confound] for fixing the above) - die if no_plan is given an argument [rt.cpan.org 27429] Test-Simple 0.80 2008-Apr-6 17:25-08:00 CEST Test fixes - Completely disable the utf8 test. It was causing perl to panic on some OS's. Test-Simple 0.79_01 2008-Feb-27 03:04-08:00 PST Bug fixes - Let's try the IO layer copying again, this time with the test fixed for 5.10. Test-Simple 0.78 2008-Feb-27 01:59-08:00 PST Bug fixes * Whoops, the version of Test::Builder::Tester got moved backwards. Test-Simple 0.77 2008-Feb-27 01:55-08:00 PST Bug fixes - "use Test::Builder::Module" no longer sets exported_to() or does any other importing. - Fix the $TODO finding code so it can find $TODO without the benefit of exported_to(), which is often wrong. - Turn off the filehandle locale stuff for the moment, there's a problem on 5.10. We'll try it again next release. Doc improvements - Improve the Test::Builder SYNOPSIS to use Test::Builder::Module rather than write it's own import(). Test-Simple 0.76_02 2008-Feb-24 13:12-08:00 PST Bug fixes * The default test output filehandles will NOT use utf8. They will now copy the IO layers from STDOUT and STDERR. This means if :utf8 is on then it will honor it and not warn about wide characters. Test-Simple 0.76_01 2008-Feb-23 20:44-08:00 PST Bug fixes * Test::Builder no longer uses a __DIE__ handler. This resolves a number of problems with exit codes being swallowed or other module's handlers being interfered with. [rt.cpan.org 25294] - Allow maybe_regex() to detect blessed regexes. [bleadperl @32880] - The default test output filehandles will now use utf8. [rt.cpan.org 21091] Test fixes - Remove the signature test. Adds no security and just generates failures. Test-Simple 0.75 2008-Feb-23 19:03-08:00 PST Incompatibilities * The minimum version is now 5.6.0. Bug fixes - Turns out require_ok() had the same bug as use_ok() in a BEGIN block. - ok() was not honoring exported_to() when looking for $TODO as it should be. Test fixes * is_deeply_with_threads.t will not run unless AUTHOR_TESTING is set. This is because it tickles intermittent threading bugs in many perls and causes a lot of bug reports about which I can do nothing. Misc - Ran through perlcritic and did some cleaning. Test-Simple 0.74 2007-Nov-29 15:39-08:00 PST Misc - Add abstract and author to the meta information. Test-Simple 0.73_01 2007-Oct-15 20:35-08:00 EDT Bug fixes * Put the use_ok() fix from 0.71 back. Test-Simple 0.72 2007-Sep-19 20:08-08:00 PDT Bug unfixes * The BEGIN { use_ok } fix for [rt.cpan.org 28345] revealed a small pile of mistakes in CPAN module test suites. Rolling the fix back to give the authors a bit of time to fix their tests. Test-Simple 0.71 2007-Sep-13 20:42-08:00 PDT Bug fixes - Fixed a problem with BEGIN { use_ok } silently failing when there's no plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. - Fixed an obscure problem with is_deeply() and overloading == [rt.cpan.org 20768]. Thanks Sisyphus. Test fixes - Removed dependency on Text::Soundex [rt.cpan.org 25022] - Fixed a 5.5.x failure in fail-more.t * Got rid of the annoying sort_bug.t test that revealed problems with some threaded perls. It was testing the deprecated eq_* functions and not worth the bother. Now it tests is_deeply(). [rt.cpan.org 17791] Doc fixes - Minor POD mistake in Test::Builder [rt.cpan.org 28869] * Test::FAQ has been updated with some more answers. Install fixes - Fixed the "LICENSE is not a known MakeMaker parameter name" warning on older MakeMakers for real this time. Test-Simple 0.70 2007-Mar-15 15:53-08:00 PDT Bug Fixes * The change to is_fh() in 0.68 broke the case where a reference to a tied filehandle is used for perl 5.6 and back. This made the tests puke their guts out. Test-Simple 0.69 2007-Mar-14 06:43-08:00 PDT Test fixes - Minor filename compatibility fix to t/fail-more.t [rt.cpan.org 25428] Test-Simple 0.68 2007-Mar-13 17:27-08:00 PDT Bug fixes * If your code has a $SIG{__DIE__} handler in some cases functions like use_ok(), require_ok(), can_ok() and isa_ok() could trigger that handler. [rt.cpan.org 23509] - Minor improvement to TB's filehandle detection in the case of overridden isa(). [rt.cpan.org 20890] - Will now install as a core module in 5.6.2 which ships with Test::More. [rt.cpan.org 25163] New Features - Test::Builder->is_fh() provides a way to determine if a thing can be used as a filehandle. Documentation improvements - Improved the docs for $Test::Builder::Level showing the encouraged use (increment, don't set) - Documented the return value of Test::Builder's test methods - Split out TB's method documentation to differenciate between test methods (ok, is_eq...), methods useful in testing (skip, BAILOUT...) and methods useful for building your own tests (maybe_regex...). Test fixes - We required too old a version of Test::Pod::Coverage. Need 1.08 and not 1.00. [rt.cpan.org 25351] Test-Simple 0.67 2007-Jan-22 13:27-08:00 PST Test fixes - t/pod_coverage.t would fail if Test::Pod::Coverage between 1.07 and 1.00 were installed as it depended on all_modules being exported. [rt.cpan.org 24483] Test-Simple 0.66 2006-Dec-3 15:25-08:00 PST - Restore 5.4.5 compatibility (unobe@cpan.org) [rt.cpan.org 20513] Test-Simple 0.65 2006-Nov-10 10:26-08:00 CST Test-Simple 0.64_03 2006-Nov-5 13:09-08:00 EST - Tests will no longer warn when run against an alpha version of Test::Harness [rt.cpan.org #20501] - Now testing our POD and POD coverage. - Added a LICENSE field. - Removed warning from the docs about mixing numbered and unnumbered tests. There's nothing wrong with that. [rt.cpan.org 21358] - Change doc examples to talk about $got and $expected rather than $this and $that to correspond better to the diagnostic output [rt.cpan.org 2655] Test-Simple 0.64_02 2006-Sep-9 12:16-08:00 EDT - Last release broke Perls earlier than 5.8. Test-Simple 0.64_01 2006-Sep-4 04:40-08:00 EDT - Small improvement to the docs to avoid user confusion over "use Test::More tests => $num_tests" (Thanks Eric Wilhelm) - Minor fix for a test failure in is_deeply_fail for some Windows users. Not a real bug. [rt.cpan.org 21310] - _print_diag() accidentally leaked into the public documentation. It is a private method. * Added Test::Builder->carp() and croak() * Made most of the error messages report in the caller's context. [rt.cpan.org #20639] * Made the failure diagnostic message file and line reporting portion match Perl's for easier integration with Perl aware editors. (so its "at $file line $line_num." now) [rt.cpan.org #20639] * 5.8.0 threads are no longer supported. There's too many bugs. Test-Simple 0.64 2006-Jul-16 02:47-08:00 PDT * 0.63's change to test_fail() broke backwards compatibility. They have been removed for the time being. test_pass() went with it. This is [rt.cpan.org 11317] and [rt.cpan.org 11319]. - skip() will now warn if you get the args backwards. Test-Simple 0.63 2006-Jul-9 02:36-08:00 PDT * Fixed can_ok() to gracefully handle no class name. Submitted by "Pete Krawczyk" Implemented by "Richard Foley" [rt.cpan.org 15654] * Added test_pass() to Test::Builder::Tester rather than having to call test_out("ok 1 - foo"). [rt.cpan.org 11317] * test_fail() now accepts a test diagnostic rather than having to call test_out() separately. [rt.cpan.org 11319] - Changed Test::Builder::Tester docs to show best practice using test_fail() and test_pass(). - isnt_num() doc example wrongly showed is_num(). - Fixed a minor typo in the BAIL_OUT() docs. - Removed the LICENSE field from the Makefile.PL as the release of MakeMaker with that feature has been delayed. Test-Simple 0.62 2005-Oct-8 01:25-08:00 PDT * Absorbed Test::Builder::Tester. The last release broke it because its screen scraping Test::More and the failure output changed. By distributing them together we ensure TBT won't break again. * Test::Builder->BAILOUT() was missing. - is_deeply() can now handle function and code refs in a very limited way. It simply looks to see if they have the same referent. [rt.cpan.org 14746] Test-Simple 0.61 2005-Sep-23 23:26-08:00 PDT - create.t was trying to read from a file before it had been closed (and thus the changes may not have yet been written). * is_deeply() would call stringification methods on non-object strings which happened to be the name of a string overloaded class. [rt.cpan.org 14675] Test-Simple 0.60_02 2005-Aug-9 00:27-08:00 PDT * Added Test::Builder::Module. - Changed Test::More and Test::Simple to use Test::Builder::Module - Minor Win32 testing nit in fail-more.t * Added no_diag() method to Test::Builder and changed Test::More's no_diag internals to use that. [rt.cpan.org 8655] * Deprecated no_diag() as an option to "use Test::More". Call the Test::Builder method instead. Test-Simple 0.60_01 2005-Jul-3 18:11-08:00 PDT - Moved the docs around a little to better group all the testing functions together. [rt.cpan.org 8388] * Added a BAIL_OUT() function to Test::More [rt.cpan.org 8381] - Changed Test::Builder->BAILOUT to BAIL_OUT to match other method's naming conventions. BAILOUT remains but is deprecated. * Changed the standard failure diagnostics to include the test name. [rt.cpan.org 12490] - is_deeply() was broken for overloaded objects in the top level in 0.59_01. [rt.cpan.org 13506] - String overloaded objects without an 'eq' or '==' method are now handled in cmp_ok() and is(). - cmp_ok() will now treat overloaded objects as numbers if the comparison operator is numeric. [rt.cpan.org 13156] - cmp_ok(), like() and unlike will now throw uninit warnings if their arguments are undefined. [rt.cpan.org 13155] - cmp_ok() will now throw warnings as if the comparison were run normally, for example cmp_ok(2, '==', 'foo') will warn about 'foo' not being numeric. Previously all warnings in the comparison were suppressed. [rt.cpan.org 13155] - Tests will now report *both* the number of tests failed and if the wrong number of tests were run. Previously if tests failed and the wrong number were run it would only report the latter. [rt.cpan.org 13494] - Missing or extra tests are not considered failures for the purposes of calculating the exit code. Should there be no failures but the wrong number of tests the exit code will be 254. - Avoiding an unbalanced sort in eq_set() [bugs.perl.org 36354] - Documenting that eq_set() doesn't deal well with refs. - Clarified how is_deeply() compares a bit. * Once again working on 5.4.5. Test-Simple 0.60 2005-May-3 14:20-08:00 PDT Test-Simple 0.59_01 2005-Apr-26 21:51-08:00 PDT * Test::Builder now has a create() method which allows you to create a brand spanking new Test::Builder object. * require_ok() was not working for single letter module names. * is_deeply() and eq_* now work with circular scalar references (Thanks Fergal) * Use of eq_* now officially discouraged. - Removed eq_* from the SYNOPSIS. - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] - is_deeply() was mistakenly interpreting the same reference used twice in a data structure as being circular causing failures. [rt.cpan.org 11623] - Loading Test::Builder but not using it would interfere with the exit code if the code exited. [rt.cpan.org 12310] - is_deeply() diagnostics now disambiguate between stringified references and references. [rt.cpan.org 8865] - Files opened by the output methods are now autoflushed. - todo() now honors $Level when looking for $TODO. Test-Simple 0.54 2004-Dec-15 04:18-08:00 EST * $how_many is optional for skip() and todo_skip(). Thanks to Devel::Cover for pointing this out. - Removed a user defined function called err() in the tests to placate users of older versions of the dor patch before err() was weakend. [rt.cpan.org 8734] Test-Simple 0.53_01 2004-Dec-11 19:02-08:00 EST - current_test() can now be set backward. - *output() methods now handle tied handles and *FOO{IO} properly. - maybe_regex() now handles undef gracefully. - maybe_regex() now handles 'm,foo,' style regexes. - sort_bug.t wasn't checking for threads properly. Would fail on 5.6 that had ithreads compiled in. [rt.cpan.org 8765] Test-Simple 0.53 2004-Nov-29 04:43-08:00 EST - Apparently its possible to have Module::Signature installed without it being functional. Fixed the signature test to account for this. (not a real bug) Test-Simple 0.52 2004-Nov-28 21:41-08:00 EST - plan() now better checks that the given plan is valid. [rt.cpan.org 2597] Test-Simple 0.51_02 2004-Nov-27 01:25-08:00 EST * is_deeply() and all the eq_* functions now handle circular data structures. [rt.cpan.org 7289] * require_ok() now handles filepaths in addition to modules. - Clarifying Test::More's position on overloaded objects - Fixed a bug introduced in 0.51_01 causing is_deeply() to pierce overloaded objects. - Mentioning rt.cpan.org for reporting bugs. Test-Simple 0.51_01 2004-Nov-26 02:59-08:00 EST - plan() was accidentally exporting functions [rt.cpan.org 8385] * diag @msgs would insert # between arguments. [rt.cpan.org 8392] * eq_set() could cause problems under threads due to a weird sort bug [rt.cpan.org 6782] * undef no longer equals '' in is_deeply() [rt.cpan.org 6837] * is_deeply() would sometimes compare references as strings. [rt.cpan.org 7031] - eq_array() and eq_hash() could hold onto references if they failed keeping them in memory and preventing DESTROY. [rt.cpan.org 7032] * is_deeply() could confuse [] with a non-existing value [rt.cpan.org 7030] - is_deeply() diagnostics a little off when scalar refs were inside an array or hash ref [rt.cpan.org 7033] - Thanks to Fergal Daly for ferretting out all these long standing is_deeply and eq_* bugs. Test-Simple 0.51 2004-Nov-23 04:51-08:00 EST - Fixed bug in fail_one.t on Windows (not a real bug). - TODO reasons as overloaded objects now won't blow up under threads. [Autrijus Tang] - skip() in 0.50 tickled yet another bug in threads::shared. Hacked around it. Test-Simple 0.50 2004-Nov-20 00:28-08:00 EST - Fixed bug in fail-more test on Windows (not a real bug). [rt.cpan.org 8022] - Change from CVS to SVK. Hopefully this is the last time I move version control systems. - Again removing File::Spec dependency (came back in 0.48_02) - Change from Aegis back to CVS Test-Simple 0.49 2004-Oct-14 21:58-08:00 EDT - t/harness_active.t would fail for frivolous reasons with older MakeMakers (test bug) [thanks Bill Moseley for noticing] Test-Simple 0.48_02 2004-Jul-19 02:07-08:00 EDT * Overloaded objects as names now won't blow up under threads [rt.cpan.org 4218 and 4232] * Overloaded objects which stringify to undef used as test names now won't cause internal uninit warnings. [rt.cpan.org 4232] * Failure diagnostics now come out on their own line when run in Test::Harness. - eq_set() sometimes wasn't giving the right results if nested refs were involved [rt.cpan.org 3747] - isnt() giving wrong diagnostics and warning if given any undefs. * Give unlike() the right prototype [rt.cpan.org 4944] - Change from CVS to Aegis - is_deeply() will now do some basic argument checks to guard against accidentally passing in a whole array instead of its reference. - Mentioning Test::Differences, Test::Deep and Bundle::Test. - Removed dependency on File::Spec. - Fixing the grammar of diagnostic outputs when only a single test is run or failed (ie. "Looks like you failed 1 tests"). [Darren Chamberlain] Test-Simple 0.48_01 2002-Nov-11 02:36-08:00 EST - Mention Test::Class in Test::More's SEE ALSO * use_ok() now DWIM for version checks - More problems with ithreads fixed. * Test::Harness upgrade no longer optional. It was causing too many problems when the T::H upgrade didn't work. * Drew Taylor added a 'no_diag' option to Test::More to switch off all diag() statements. * Test::Builder/More no longer automatically loads threads.pm when threads are enabled. The user must now do this manually. * Alex Francis added reset() reset the state of Test::Builder in persistent environments. - David Hand noted that Test::Builder/More exit code behavior was not documented. Only Test::Simple. Test-Simple 0.47 2002-Aug-26 03:54-08:00 PDT * Tatsuhiko Miyagawa noticed Test::Builder was accidentally storing objects passed into test functions causing problems with tests relying on object destruction. - Added example of calculating the number of tests to Test::Tutorial - Peter Scott made the ending logic not fire on child processes when forking. * Test::Builder is once again ithread safe. Test-Simple 0.46 2002-Jul-20 19:57-08:00 EDT - Noted eq_set() isn't really a set comparison. - Test fix, exit codes are broken on MacPerl (bleadperl@16868) - Make Test::Simple install itself into the core for >= 5.8 - Small fixes to Test::Tutorial and skip examples * Added TB->has_plan() from Adrian Howard - Clarified the meaning of 'actual_ok' from TB->details * Added TB->details() from chromatic - Neil Watkiss fixed a pre-5.8 test glitch with threads.t * If the test died before a plan, it would exit with 0 [ID 20020716.013] Test-Simple 0.45 2002-Jun-19 18:41-08:00 EDT - Andy Lester made the SKIP & TODO docs a bit clearer. - Explicitly disallowing double plans. (RT #553) - Kicking up the minimum version of Test::Harness to one that's fairly bug free. - Made clear a common problem with use_ok and BEGIN blocks. - Arthur Bergman made Test::Builder thread-safe. Test-Simple 0.44 2002-Apr-25 00:27-08:00 EDT - names containing newlines no longer produce confusing output (from chromatic) - chromatic provided a fix so can_ok() honors can() overrides. - Nick Ing-Simmons suggested todo_skip() be a bit clearer about the skipping part. - Making plan() vomit if it gets something it doesn't understand. - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls. - quieting diag(undef) Test-Simple 0.43 2002-Apr-11 22:55-08:00 EDT - Adrian Howard added TB->maybe_regex() - Adding Mark Fowler's suggestion to make diag() return false. - TB->current_test() still not working when no tests were run via TB itself. Fixed by Dave Rolsky. Test-Simple 0.42 2002-Mar-6 15:00-08:00 EST - Setting Test::Builder->current_test() now works (see what happens when you forget to test things?) - The change in is()'s undef/'' handling in 0.34 was an API change, but I forgot to declare it as such. - The apostrophilic jihad attacks! Philip Newtons patch for grammar mistakes in the doc's. Test-Simple 0.41 2001-Dec-17 22:45-08:00 EST * chromatic added diag() - Internal eval()'s sometimes interfering with $@ and $!. Fixed. Test-Simple 0.40 2001-Dec-14 15:41-08:00 EST * isa_ok() now accepts unblessed references gracefully - Nick Clark found a bug with like() and a regex with % in it. - exit.t was hanging on 5.005_03 VMS perl. Test now skipped. - can_ok() would pass if no methods were given. Now fails. - isnt() diagnostic output format changed * Added some docs about embedding and extending Test::More * Added Test::More->builder * Added cmp_ok() * Added todo_skip() * Added unlike() - Piers pointed out that sometimes people override isa(). isa_ok() now accounts for that. Test-Simple 0.36 2001-Nov-29 14:07-08:00 EST - Matthias Urlichs found that intermixed prints to STDOUT and test output came out in the wrong order when piped. Test-Simple 0.35 2001-Nov-27 19:57-08:00 EST - Little glitch in the test suite. No actual bug. Test-Simple 0.34 2001-Nov-27 15:43-08:00 EST * **API CHANGE** Empty string no longer matches undef in is() and isnt(). * Added isnt_eq and isnt_num to Test::Builder. Test-Simple 0.33 2001-Oct-22 21:05-08:00 EDT * It's now officially safe to redirect STDOUT and STDERR without affecting test output. - License and POD cleanup by Autrijus Tang - Synched up Test::Tutorial with the wiki version - Minor VMS test nit. Test-Simple 0.32 2001-Oct-16 16:52-08:00 EDT * Finally added a separate plan() function * Adding a name field to isa_ok() (Requested by Dave Rolsky) - Test::More was using Carp.pm, causing the occasional false positive. (Reported by Tatsuhiko Miyagawa) Test-Simple 0.31 2001-Oct-8 19:24-08:00 EDT * Added an import option to Test::More * Added no_ending and no_header options to Test::Builder (Thanks to Dave Rolsky for giving this a swift kick in the ass) * Added is_deeply(). Display of scalar refs not quite 100% (Thanks to Stas Bekman for Apache::TestUtil idea thievery) - Fixed a minor warning with skip() (Thanks to Wolfgang Weisselberg for finding this one) Test-Simple 0.30 2001-Sep-27 22:10-08:00 EDT * Added Test::Builder (Thanks muchly to chromatic for getting this off the ground!) * Diagnostics are back to using STDERR *unless* it's from a todo test. Those go to STDOUT. - Fixed it so nothing is printed if a test is run with a -c flag. Handy when a test is being deparsed with B::Deparse. Test-Simple 0.20 *UNRELEASED* Test-Simple 0.19 2001-Sep-18 17:48-08:00 EDT * Test::Simple and Test::More no longer print their diagnostics to STDERR. It instead goes to STDOUT. * TODO tests which fail now print full failure diagnostics. - Minor bug in ok()'s test name diagnostics made it think a blank name was a number. - ok() less draconian about test names - Added temporary special case for Parrot::Test - Now requiring File::Spec for our tests. Test-Simple 0.18 2001-Sep-5 20:35-08:00 EDT * ***API CHANGE*** can_ok() only counts as one test - can_ok() has better diagnostics - Minor POD fixes from mjd - adjusting the internal layout to make it easier to put it into the core Test-Simple 0.17 2001-Aug-29 20:16-08:00 EDT * Added can_ok() and isa_ok() to Test::More Test-Simple 0.16 2001-Aug-28 19:52-08:00 EDT * vmsperl foiled my sensible exit codes. Reverting to a much more coarse scheme. Test-Simple 0.15 2001-Aug-28 06:18-08:00 EDT *UNRELEASED* * Now using sensible exit codes on VMS. Test-Simple 0.14 2001-Aug-22 17:26-08:00 EDT * Added a first cut at Test::Tutorial Test-Simple 0.13 2001-Aug-14 15:30-08:00 EDT * Added a reason to the skip_all interface - Fixed a bug to allow 'use Test::More;' to work. (Thanks to Tatsuhiko Miyagawa again) - Now always testing backwards compatibility. Test-Simple 0.12 2001-Aug-14 11:02-08:00 EDT * Fixed some compatibility bugs with older Perls (Thanks to Tatsuhiko Miyagawa) Test-Simple 0.11 2001-Aug-11 23:05-08:00 EDT * Will no longer warn about testing undef values - Escaping # in test names - Ensuring that ok() returns true or false and not undef - Minor doc typo in the example Test-Simple 0.10 2001-Jul-31 15:01-08:00 EDT * Test::More is now distributed in this tarball. * skip and todo tests work! * Extended use_ok() so it can import - A little internal rejiggering - Added a TODO file Test-Simple 0.09 2001-Jun-27 02:55-08:00 EDT - VMS fixes Test-Simple 0.08 2001-Jun-15 14:39-08:00 EDT - Guarding against $/ and -l - Reformatted the way failed tests are reported to make them stand out a bit better. Test-Simple 0.07 2001-Jun-12 15:55-08:00 BST - 'use Test::Simple' by itself no longer causes death - Yet more fixes for death in eval - Limiting max failures reported via exit code to 254. Test-Simple 0.06 2001-May-9 23:38-08:00 BST - Whoops, left a private method in the public docs. Test-Simple 0.05 2001-May-9 20:40-08:00 BST - Forgot to include the exit tests. - Trouble with exiting properly under 5.005_03 and 5.6.1 fixed - Turned off buffering * 5.004 new minimum version - Now explicitly tested with 5.6.1, 5.6.0, 5.005_03 and 5.004 Test-Simple 0.04 2001-Apr-2 11:05-08:00 BST - Fixed "require Test::Simple" so it doesn't bitch and exit 255 - Now installable with the CPAN shell. Test-Simple 0.03 2001-Mar-30 08:08-08:00 BST - ok() now prints on what line and file it failed. - eval 'die' was considered abnormal. Fixed. Test-Simple 0.02 2001-Mar-30 05:12-08:00 BST *UNRELEASED* - exit codes tested * exit code on abnormal exit changed to 255 (thanks to Tim Bunce for pointing out that Unix can't do negative exit codes) - abnormal exits now better caught. - No longer using Test.pm to test this, but still minimum of 5.005 due to needing $^S. Test-Simple 0.01 2001-Mar-28 06:44-08:00 BST - First working version released to CPAN Test2 0.000044 2016-04-30 13:56:25-07:00 America/Los_Angeles - Remove things that should nto have been backported from Test-Simple merger Test2 0.000043 2016-04-30 05:21:51-07:00 America/Los_Angeles - Better error messages when using Carp in Hashbase init() - Document 2 methods on Events - Fix #17 (typo fix in docs) Test2 0.000042 2016-04-15 13:17:21-07:00 America/Los_Angeles - Let TAP render generic events - Add the no_display method to the Event API - Improve T2_FORMATTER parsing Test2 0.000041 2016-04-13 20:21:38-07:00 America/Los_Angeles - Do not use custom formatter in sensitive tests Test2 0.000040 2016-04-05 11:09:52-07:00 America/Los_Angeles - Track subtest info inside subtest events Test2 0.000039 2016-04-04 21:32:08-07:00 America/Los_Angeles - Formatters can pick buffered subtest behavior - Add sets_plan() method to event base class - Add diagnostics() method to event base class Test2 0.000038 2016-04-03 15:41:39-07:00 America/Los_Angeles - Add summary() method to event base class Test2 0.000037 2016-04-01 08:41:22-07:00 America/Los_Angeles - Change Formatter to load Test2::API on demand - Add test to insure Test2::API is not loaded by some modules Test2 0.000036 2016-03-28 11:44:53-07:00 America/Los_Angeles - Do not warn if unimportant INIT block cannot be run - Change how TAP duplicates IO handles, use 3 arg form of open Test2 0.000035 2016-03-25 09:41:46-07:00 America/Los_Angeles (TRIAL RELEASE) - More fixes for #16 - Add some END block manipulation for #16 - Turn off depth checking on older perls (for #16) Test2 0.000034 2016-03-24 10:32:57-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix depth bug introduced in the last trial Test2 0.000033 2016-03-24 08:39:51-07:00 America/Los_Angeles (TRIAL RELEASE) - Better fox for #16 (workaround for caller() in END bug) - Put test for #16 in regular testing dir as new fix is more stable Test2 0.000032 2016-03-23 23:54:40-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix #16 (workaround for caller() in END bug) Test2 0.000031 2016-03-20 13:45:43-07:00 America/Los_Angeles - Regenerate README files - Apply spelling fixes (aquire->acquire) #11 - Improve error message for missing hubs #12 Test2 0.000030 2016-03-15 08:04:21-07:00 America/Los_Angeles - Re-Add transition document Test2 0.000029 2016-03-09 10:04:19-08:00 America/Los_Angeles - Add pid to Files driver temp dir name Test2 0.000028 2016-03-09 09:03:26-08:00 America/Los_Angeles - Environment var to control IPC::Driver::Files temp dir templates Test2 0.000027 2016-03-07 12:16:34-08:00 America/Los_Angeles - Ability to disable skip_all subtest abort construct Test2 0.000026 2016-03-06 20:15:19-08:00 America/Los_Angeles - Version number in all modules (autarch) - Fix rare/minor Race condition in Files IPC driver - skip-all plan is not global anymore (never should have been) - skip-all properly aborts in child proc/thread - don't override defined but falsy pid/rid in traces Test2 0.000025 2016-02-02 12:08:32-08:00 America/Los_Angeles - Fix occasional warning in cleanup Test2 0.000024 2016-01-29 21:16:56-08:00 America/Los_Angeles - Add no_context() (needed for external tool) Test2 0.000023 2016-01-28 20:34:09-08:00 America/Los_Angeles - Add context_do() - Add context_aquire hooks - Documentation updates - Typo fixes (thanks rjbs) - Minor enhancement to test tools Test2 0.000022 2016-01-18 11:58:40-08:00 America/Los_Angeles - Fix test that broke in the last release (oops) Test2 0.000021 2016-01-18 10:54:54-08:00 America/Los_Angeles - Fix bug where default diagnostics were not shown for subtests. Test2 0.000020 2016-01-14 21:52:43-08:00 America/Los_Angeles - Change how contexts are stacked - More/better messages when contexts are abused - better handling of $@, $!, and $? - Add pre_filter and pre_unfilter to Hubs Test2 0.000019 2016-01-12 16:08:11-08:00 America/Los_Angeles - Make third-party meta-data interface consistent. Test2 0.000018 2016-01-12 05:53:29-08:00 America/Los_Angeles - Better solution to the $?, $!, and $@ problem - error vars are stored/restored by the context Test2 0.000017 2016-01-11 16:33:55-08:00 America/Los_Angeles - Fix $! squashing Test2 0.000016 2016-01-10 11:54:57-08:00 America/Los_Angeles - Better encapsulation of API::Instance - API methods to get lists of hooks - Minor fixes to IPC shm logic - Preload event types when API is loaded - Added IPC acceptance tests Test2 0.000015 2016-01-07 19:26:58-08:00 America/Los_Angeles - Make it possible to use a custom new() with HashBase Test2 0.000014 2016-01-07 07:31:23-08:00 America/Los_Angeles - Silence a warning in older perls (warning breaks Test-Simple tests) Test2 0.000013 2016-01-06 11:12:21-08:00 America/Los_Angeles - Remove diag from inside todo (separation of concerns, less TAP influence) - Remove internal TODO tracking (not needed, less TAP influence) - Make context less magic (Follwing advice from Graham Knop and RJBS) - Remove State.pm (part of Hub.pm again, no longer needs to be separate) - Make it possible to subclass the TAP formatter - Minor optimization in Event->meta - Better messaging if subtest plan is wrong - HashBase in subclass will not override accessors from parent (Graham Knop) - TAP formatter doc updates - Optimizations for Hub->process and TAP->Write - IPC File-Driver Optimizations - IPC use SHM when possible to notify about pending events Test2 0.000012 2015-12-29 12:59:26-08:00 America/Los_Angeles - Restructure file layout - Document namespaces - Combine Global and API into a single module Test2 0.000011 2015-12-28 13:09:38-08:00 America/Los_Angeles - Fix TAP output to match what Test::More produced Test2 0.000010 2015-12-21 13:13:33-08:00 America/Los_Angeles - Rename Test2.pm to Test2/API.pm. - Turn Global.pm into and exporter. Test2 0.000009 2015-12-21 10:13:18-08:00 America/Los_Angeles - Fix typo in Test2::Event Test2 0.000008 2015-12-21 09:54:58-08:00 America/Los_Angeles - Bring back 'release' export of Test2. Test2 0.000007 2015-12-20 12:09:04-08:00 America/Los_Angeles - Fix version number string - Fix typo Test2 0.000006 2015-12-15 20:30:46-08:00 America/Los_Angeles - Port 00-report.t from old form - Prevent TAP from killing $! - Fix Instance.t - Typo fix - Comment Contex.pm better, fix minor bug - Better error in Trace.pm constructor - Test2.pm, comments, and do not use try - Improve try, remove protect - Remove unused imports - Fix profling scripts - Improve HashBase - IPC improvements - Doc fix Test2 0.000005 2015-12-14 20:21:34-08:00 America/Los_Angeles - Pull out guts into Test2 namespace - Restructure module paths - Simplify HashBase - Combine Util and Capabilities - Update Profiling scripts - Rename DebugInfo to Trace - Rename SyncObj to Global/Instance - Slim down Util.pm - Stop using Test::Stream::Exporter - Reduce complexity of Capabilities checker - Use event todo instead of debuginfo todo - Add 'todo' fields for Diag and Ok events - Break out Skip into an event type - Add event registration to TAP formatter - Move to_tap logic into formatter Test-Stream 1.302026 2015-11-09 14:34:30-08:00 America/Los_Angeles - No functional changes since the last trial - Doc fix (fixes #52) - Doc fix (fixes #55) - Doc fix in Classic bundle - Doc fixes for FromTestBuilder Test-Stream 1.302025 2015-11-06 16:33:06-08:00 America/Los_Angeles (TRIAL RELEASE) - Add back cmp_ok in Core plugin - Add Classic plugin for legacy is/like/is_deeply/etc - Make docs recommend people moving from Test::More use -Classic Test-Stream 1.302024 2015-11-04 11:15:14-08:00 America/Los_Angeles - Add missing undef compare test Test-Stream 1.302023 2015-11-04 00:12:49-08:00 America/Los_Angeles (TRIAL RELEASE) - String and Number comparisons no longer allow undef (backwards-incompatible change, sorry) - Doc spelling fixes (Evan Zacks) - Add Undef type in deep check - Fix docs for buffered subtests (Noticed by Magnolia.K) Test-Stream 1.302022 2015-11-03 09:43:39-08:00 America/Los_Angeles - Change Delta.pm to use a grep instead of a map (minor change) - Fix scalar-ref comparison for overloaded scalar refs (#50) Test-Stream 1.302021 2015-10-31 08:15:22-07:00 America/Los_Angeles - Remove all number vs string guessing - Doc fixes (thanks Magnolia.K) - Add details to test report Test-Stream 1.302020 2015-10-29 08:02:25-07:00 America/Los_Angeles - No changes, just removing trial Test-Stream 1.302019 2015-10-28 22:32:06-07:00 America/Los_Angeles (TRIAL RELEASE) - Declare Test::Stream experimental phase complete - Updated Readme - Add tooling manual page - Better Trace::Mask behavior - Added Components manual page - Remove or modify experimental notice - Remove stray debugging statements - Slight change in module list in t/00-report.t Test-Stream 1.302018 2015-10-26 16:47:45-07:00 America/Los_Angeles - Better stack traces in spec - Remove duplicate module from the report - Rename subs in try {} and protect {} - Fix loop in SkipWithout - Fix Typo in Context pod Test-Stream 1.302017 2015-10-15 21:32:50-07:00 America/Los_Angeles - Change minimum module versions (they were wrong) - Typo fixes in Test::Stream docs - Remove unused variable - Fix Compare line number bug Test-Stream 1.302016 2015-10-12 18:49:35-07:00 America/Los_Angeles - Workflows/Spec: Argument tolerence, custom line numbers - Remove Block.pm - Add sub_info and sub_name to Util.pm - Workflows: Set sub name if possible (better debugging) - Add "Test" that prints deps and versions - Add 'class', 'skip_without', and 'srand' to Test::Stream as options - Even Core deps now listed in dist.ini - Add some missing docs and tests to Util.pm Test-Stream 1.302015 2015-10-04 13:46:56-07:00 America/Los_Angeles - Remove spec isolation logic, this can be an external plugin Test-Stream 1.302014 2015-10-03 20:30:14-07:00 America/Los_Angeles - Another Delta.t fix Test-Stream 1.302013 2015-10-02 21:51:45-07:00 America/Los_Angeles - Fix Util.t for some Term::ReadKey versions Test-Stream 1.302012 2015-10-01 15:42:27-07:00 America/Los_Angeles - Remove reservations file - Documentation updates (add missing docs) - Fix output handle in subtest diagnostics - Better subtest diagnostics - Whitespace fixes - Better error handling in threads in the workflows - Better support real fork vs pseudo fork Test-Stream 1.302011 2015-09-30 21:05:57-07:00 America/Los_Angeles - Documentation updates, typo fixes - Be safer, and less verbose, when detecting term size - Fix isolation in the spec plugin in windows - Skip sync test on windows (temporary measure) - Skip the hub.t fork check on windows (temporary measure) - Add some debugging to CanThread - Fix global event handling on platforms that do not use '/' for path - Fix Delta.t on systems with large memory addresses Test-Stream 1.302010 2015-09-29 22:23:28-07:00 America/Los_Angeles - Add spec plugin (with basic workflows modules) - Switch to plugin architecture, Test::Stream is just a loader - Add plugins (many of these were non-plugins before) AuthorTest BailOnFail Capabilities Capture Class Compare Context Core Defer DieOnFail Exception ExitSummary Grab IPC Intercept LoadPlugin Mock SRand SkipWithout Spec Subtest TAP UTF8 Warnings - CanFork is now a plugin - CanThread is now a plugin - Subtest stack fallback fix - Better Compare library - Documentation is fleshed out and mostly complete - Unit testing coverage is now satisfactory - Better detection of broken threads on 5.10.0 - Ability to set/change encoding - is_deeply() is now combined into is() - mostly_like() and like() are combined - DeepCheck library removed in favor of Compare library - deep checks now render a table - Test directory restructuring - Mocking library - Workflow library - Fix typos - Fix a GC destruction issue (b3a96db) Test-Stream 1.302009 2015-07-03 21:16:08-07:00 America/Los_Angeles - Fix MANIFEST.SKIP so tests are not skipped - Change import aliasing syntax to match prior art - Fix bug in does_ok - Documentation updates Test-Stream 1.302008 2015-06-27 15:21:55-07:00 America/Los_Angeles - Fix 2 bugs with threading on 5.8.x - Fix a diag rendering bug with subtests Test-Stream 1.302007 2015-06-24 08:03:38-07:00 America/Los_Angeles - Add CanThread and CanFork libraries - Remove prefix when subtests are buffered - Fix bug where Exporter might remove other tools exports - Fix bug in unmunge and unlisten - Add helper for specifying a context in which to run - Add causes_fail method for events - Fix rendering bug in subtest diags - Fix bug where IPC abort would fail to set exit code - Remove XS support code - Fix bug when threads are auto-joined Test-Stream 1.302006 2015-06-18 09:53:04-07:00 America/Los_Angeles - MANIFEST.SKIP fix - Remove files accidentally included in the last dist Test-Stream 1.302005 2015-06-18 09:37:38-07:00 America/Los_Angeles - Remove broken test script Test-Stream 1.302004 2015-06-17 08:32:31-07:00 America/Los_Angeles - Add Support for XS - Improve release_pp with refcount from internals Test-Stream 1.302003 2015-06-06 21:44:42-07:00 America/Los_Angeles - Documentation added - Make IPC::Files safe in cleanup Test-Stream 1.302002 2015-06-06 14:06:57-07:00 America/Los_Angeles - Fix Win32 support Test-Stream 1.302001 2015-06-05 22:40:57-07:00 America/Los_Angeles - Initial Version Test-Simple-1.302125/LICENSE0000644000175000017500000004365213243466361015064 0ustar exodistexodistThis software is copyright (c) 2018 by Chad Granum. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2018 by Chad Granum. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2018 by Chad Granum. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Test-Simple-1.302125/README0000644000175000017500000001433213243466361014730 0ustar exodistexodistNAME Test2 - Framework for writing test tools that all work together. DESCRIPTION Test2 is a new testing framework produced by forking Test::Builder, completely refactoring it, adding many new features and capabilities. WHAT IS NEW? Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with Test2::API::intercept(). Better diagnostics capabilities. Test2 uses an Test2::API::Context object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. Support for threading/forking. Test2 support for forking and threading can be turned on using Test2::IPC. Once turned on threading and forking operate sanely and work as one would expect. GETTING STARTED If you are interested in writing tests using new tools then you should look at Test2::Suite. Test2::Suite is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at Test2::API first. NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in Test2::Suite. Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like ok() and is(). Most things written for Test2 should go here. Modules in this namespace MUST NOT export subs from other tools. See the "Test2::Bundle::" namespace if you want to do that. Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. Test2::Formatter:: Formatters live under this namespace. Test2::Formatter::TAP is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. Test2::API:: This is for Test2 API and related packages. Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into Test2::XXX. SEE ALSO Test2::API - Primary API functions. Test2::API::Context - Detailed documentation of the context object. Test2::IPC - The IPC system used for threading/fork support. Test2::Formatter - Formatters such as TAP live here. Test2::Event - Events live in this namespace. Test2::Hub - All events eventually funnel through a hub. Custom hubs are how intercept() and run_subtest() are implemented. CONTACTING US Many Test2 developers and users lurk on irc://irc.perl.org/#perl-qa and irc://irc.perl.org/#toolchain. We also have a slack team that can be joined by anyone with an @cpan.org email address https://perl-test2.slack.com/ If you do not have an @cpan.org email you can ask for a slack invite by emailing Chad Granum . SOURCE The source code repository for Test2 can be found at http://github.com/Test-More/test-more/. MAINTAINERS Chad Granum AUTHORS Chad Granum COPYRIGHT Copyright 2018 Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://dev.perl.org/licenses/