diff options
Diffstat (limited to 'cpan/Test-Simple/lib/Test')
48 files changed, 15174 insertions, 3148 deletions
diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index e10e102987..e871ae152e 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -1,1549 +1,698 @@ package Test::Builder; -use 5.006; +use 5.008001; use strict; use warnings; -our $VERSION = '1.001009'; +our $VERSION = '1.301001_071'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -BEGIN { - if( $] < 5.008 ) { - require Test::Builder::IO::Scalar; - } -} +use Test::Stream 1.301001 qw/ -internal STATE_LEGACY STATE_PLAN STATE_COUNT /; +use Test::Stream::Toolset; +use Test::Stream::Context; +use Test::Stream::Carp qw/confess/; +use Test::Stream::Meta qw/MODERN/; -# Make Test::Builder thread-safe for ithreads. -BEGIN { - use Config; - # Load threads::shared when threads are turned on. - # 5.8.0's threads are so busted we no longer support them. - if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { - require threads::shared; - - # Hack around YET ANOTHER threads::shared bug. It would - # occasionally forget the contents of the variable when sharing it. - # So we first copy the data, then share, then put our copy back. - *share = sub (\[$@%]) { - my $type = ref $_[0]; - my $data; - - if( $type eq 'HASH' ) { - %$data = %{ $_[0] }; - } - elsif( $type eq 'ARRAY' ) { - @$data = @{ $_[0] }; - } - elsif( $type eq 'SCALAR' ) { - $$data = ${ $_[0] }; - } - else { - die( "Unknown type: " . $type ); - } - - $_[0] = &threads::shared::share( $_[0] ); - - if( $type eq 'HASH' ) { - %{ $_[0] } = %$data; - } - elsif( $type eq 'ARRAY' ) { - @{ $_[0] } = @$data; - } - elsif( $type eq 'SCALAR' ) { - ${ $_[0] } = $$data; - } - else { - die( "Unknown type: " . $type ); - } - - return $_[0]; - }; - } - # 5.8.0's threads::shared is busted when threads are off - # and earlier Perls just don't have that module at all. - else { - *share = sub { return $_[0] }; - *lock = sub { 0 }; - } -} +use Test::Stream::Util qw/try protect unoverload_str is_regex/; +use Scalar::Util qw/blessed reftype/; -=head1 NAME - -Test::Builder - Backend for building test libraries - -=head1 SYNOPSIS - - package My::Test::Module; - use base 'Test::Builder::Module'; +use Test::More::Tools; - my $CLASS = __PACKAGE__; - - sub ok { - my($test, $name) = @_; - my $tb = $CLASS->builder; +BEGIN { + my $meta = Test::Stream::Meta->is_tester('main'); + Test::Stream->shared->set_use_legacy(1) + unless $meta && $meta->[MODERN]; +} - $tb->ok($test, $name); - } +# The mostly-singleton, and other package vars. +our $Test = Test::Builder->new; +our $_ORIG_Test = $Test; +our $Level = 1; +sub ctx { + my $self = shift || die "No self in context"; + my ($add) = @_; + my $ctx = Test::Stream::Context::context(2 + ($add || 0), $self->{stream}); + if (defined $self->{Todo}) { + $ctx->set_in_todo(1); + $ctx->set_todo($self->{Todo}); + $ctx->set_diag_todo(1); + } + return $ctx; +} -=head1 DESCRIPTION +sub stream { + my $self = shift; + return $self->{stream} || Test::Stream->shared; +} -L<Test::Simple> and L<Test::More> 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<which can -work together>. +sub depth { $_[0]->{depth} || 0 } -=head2 Construction +# This is only for unit tests at this point. +sub _ending { + my $self = shift; + my ($ctx) = @_; + require Test::Stream::ExitMagic; + $self->{stream}->set_no_ending(0); + Test::Stream::ExitMagic->new->do_magic($self->{stream}, $ctx); +} + +my %WARNED; +our $CTX; +our %ORIG = ( + ok => \&ok, + diag => \&diag, + note => \¬e, + plan => \&plan, + done_testing => \&done_testing, +); -=over 4 +sub WARN_OF_OVERRIDE { + my ($sub, $ctx) = @_; -=item B<new> + return unless $ctx->modern; + my $old = $ORIG{$sub}; + # Use package instead of self, we want replaced subs, not subclass overrides. + my $new = __PACKAGE__->can($sub); - my $Test = Test::Builder->new; + return if $new == $old; -Returns a Test::Builder object representing the current state of the -test. + require B; + my $o = B::svref_2object($new); + my $gv = $o->GV; + my $st = $o->START; + my $name = $gv->NAME; + my $pkg = $gv->STASH->NAME; + my $line = $st->line; + my $file = $st->file; -Since you only run one test per program C<new> always returns the same -Test::Builder object. No matter how many times you call C<new()>, 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. + warn <<" EOT" unless $WARNED{"$pkg $name $file $line"}++; -If you want a completely new Test::Builder object different from the -singleton, use C<create>. +******************************************************************************* +Something monkeypatched Test::Builder::$sub()! +The new sub is '$pkg\::$name' defined in $file around line $line. +In the near future monkeypatching Test::Builder::ok() will no longer work +as expected. +******************************************************************************* + EOT +} -=cut -our $Test = Test::Builder->new; +#################### +# {{{ Constructors # +#################### sub new { - my($class) = shift; - $Test ||= $class->create; + my $class = shift; + my %params = @_; + $Test ||= $class->create(shared_stream => 1); + return $Test; } -=item B<create> - - 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<new()> if you're testing -a Test::Builder based module, but otherwise you probably want C<new>. - -B<NOTE>: the implementation is not complete. C<level>, for example, is -still shared amongst B<all> Test::Builder objects, even ones created using -this method. Also, the method name may change in the future. - -=cut - sub create { - my $class = shift; + my $class = shift; + my %params = @_; my $self = bless {}, $class; - $self->reset; + $self->reset(%params); return $self; } - # Copy an object, currently a shallow. # This does *not* bless the destination. This keeps the destructor from # firing when we're just storing a copy of the object to restore later. sub _copy { - my($src, $dest) = @_; - + my ($src, $dest) = @_; %$dest = %$src; - _share_keys($dest); - return; } +#################### +# }}} Constructors # +#################### -=item B<child> - - my $child = $builder->child($name_of_child); - $child->plan( tests => 4 ); - $child->ok(some_code()); - ... - $child->finalize; - -Returns a new instance of C<Test::Builder>. Any output from this child will -be indented four spaces more than the parent's indentation. When done, the -C<finalize> method I<must> be called explicitly. +############################# +# {{{ Children and subtests # +############################# -Trying to create a new child with a previous child still active (i.e., -C<finalize> not called) will C<croak>. - -Trying to run a test when you have an open child will also C<croak> and cause -the test suite to fail. - -=cut +sub subtest { + my $self = shift; + my $ctx = $self->ctx(); + return tmt->subtest(@_); +} sub child { my( $self, $name ) = @_; - if( $self->{Child_Name} ) { - $self->croak("You already have a child named ($self->{Child_Name}) running"); - } - - my $parent_in_todo = $self->in_todo; + my $ctx = $self->ctx; - # Clear $TODO for the child. - my $orig_TODO = $self->find_TODO(undef, 1, undef); + if ($self->{child}) { + my $cname = $self->{child}->{Name}; + $ctx->throw("You already have a child named ($cname) running"); + } - my $class = ref $self; - my $child = $class->create; + $name ||= "Child of " . $self->{Name}; + $ctx->child('push', $name, 1); - # Add to our indentation - $child->_indent( $self->_indent . ' ' ); + my $stream = $self->{stream} || Test::Stream->shared; - # Make the child use the same outputs as the parent - for my $method (qw(output failure_output todo_output)) { - $child->$method( $self->$method ); - } + my $child = bless { + %$self, + '?' => $?, + parent => $self, + }; - # Ensure the child understands if they're inside a TODO - if( $parent_in_todo ) { - $child->failure_output( $self->todo_output ); - } + $? = 0; + $child->{Name} = $name; + $self->{child} = $child; + Scalar::Util::weaken($self->{child}); - # This will be reset in finalize. We do this here lest one child failure - # cause all children to fail. - $child->{Child_Error} = $?; - $? = 0; - $child->{Parent} = $self; - $child->{Parent_TODO} = $orig_TODO; - $child->{Name} = $name || "Child of " . $self->name; - $self->{Child_Name} = $child->name; return $child; } - -=item B<subtest> - - $builder->subtest($name, \&subtests, @args); - -See documentation of C<subtest> in Test::More. - -C<subtest> also, and optionally, accepts arguments which will be passed to the -subtests reference. - -=cut - -sub subtest { +sub finalize { my $self = shift; - my($name, $subtests, @args) = @_; - if ('CODE' ne ref $subtests) { - $self->croak("subtest()'s second argument must be a code ref"); - } + return unless $self->{parent}; - # Turn the child into the parent so anyone who has stored a copy of - # the Test::Builder singleton will get the child. - my $error; - my $child; - my $parent = {}; - { - # child() calls reset() which sets $Level to 1, so we localize - # $Level first to limit the scope of the reset to the subtest. - local $Test::Builder::Level = $Test::Builder::Level + 1; - - # Store the guts of $self as $parent and turn $child into $self. - $child = $self->child($name); - _copy($self, $parent); - _copy($child, $self); - - my $run_the_subtests = sub { - # Add subtest name for clarification of starting point - $self->note("Subtest: $name"); - $subtests->(@args); - $self->done_testing unless $self->_plan_handled; - 1; - }; - - if( !eval { $run_the_subtests->() } ) { - $error = $@; - } - } + my $ctx = $self->ctx; - # Restore the parent and the copied child. - _copy($self, $child); - _copy($parent, $self); + if ($self->{child}) { + my $cname = $self->{child}->{Name}; + $ctx->throw("Can't call finalize() with child ($cname) active"); + } - # Restore the parent's $TODO - $self->find_TODO(undef, 1, $child->{Parent_TODO}); + $self->_ending($ctx); + my $passing = $ctx->stream->is_passing; + my $count = $ctx->stream->count; + my $name = $self->{Name}; + $ctx = undef; - # Die *after* we restore the parent. - die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; + my $stream = $self->{stream} || Test::Stream->shared; - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $finalize = $child->finalize; + my $parent = $self->parent; + $self->{parent}->{child} = undef; + $self->{parent} = undef; - $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; + $? = $self->{'?'}; - return $finalize; + $ctx = $parent->ctx; + $ctx->child('pop', $self->{Name}); } -=begin _private - -=item B<_plan_handled> - - if ( $Test->_plan_handled ) { ... } - -Returns true if the developer has explicitly handled the plan via: - -=over 4 - -=item * Explicitly setting the number of tests - -=item * Setting 'no_plan' - -=item * Set 'skip_all'. - -=back - -This is currently used in subtests when we implicitly call C<< $Test->done_testing >> -if the developer has not set a plan. - -=end _private - -=cut - -sub _plan_handled { +sub in_subtest { my $self = shift; - return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; + my $ctx = $self->ctx; + return scalar @{$ctx->stream->subtests}; } +sub parent { $_[0]->{parent} } +sub name { $_[0]->{Name} } -=item B<finalize> - - my $ok = $child->finalize; - -When your child is done running tests, you must call C<finalize> to clean up -and tell the parent your pass/fail status. - -Calling C<finalize> on a child with open children will C<croak>. - -If the child falls out of scope before C<finalize> is called, a failure -diagnostic will be issued and the child is considered to have failed. - -No attempt to call methods on a child after C<finalize> is called is -guaranteed to succeed. - -Calling this on the root builder is a no-op. - -=cut - -sub finalize { +sub DESTROY { my $self = shift; + return unless $self->{parent}; + return if $self->{Skip_All}; + $self->{parent}->is_passing(0); + my $name = $self->{Name}; + die "Child ($name) exited without calling finalize()"; +} - return unless $self->parent; - if( $self->{Child_Name} ) { - $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); - } - - local $? = 0; # don't fail if $subtests happened to set $? nonzero - $self->_ending; +############################# +# }}} Children and subtests # +############################# - # XXX This will only be necessary for TAP envelopes (we think) - #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); +##################################### +# {{{ stuff for TODO status # +##################################### - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $ok = 1; - $self->parent->{Child_Name} = undef; - unless ($self->{Bailed_Out}) { - if ( $self->{Skip_All} ) { - $self->parent->skip($self->{Skip_All}, $self->name); - } - elsif ( not @{ $self->{Test_Results} } ) { - $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); - } - else { - $self->parent->ok( $self->is_passing, $self->name ); +sub find_TODO { + my ($self, $pack, $set, $new_value) = @_; + + unless ($pack) { + if (my $ctx = Test::Stream::Context->peek) { + $pack = $ctx->package; + my $old = $ctx->todo; + $ctx->set_todo($new_value) if $set; + return $old; } - } - $? = $self->{Child_Error}; - delete $self->{Parent}; - - return $self->is_passing; -} -sub _indent { - my $self = shift; - - if( @_ ) { - $self->{Indent} = shift; + $pack = $self->exported_to || return; } - return $self->{Indent}; + no strict 'refs'; ## no critic + no warnings 'once'; + my $old_value = ${$pack . '::TODO'}; + $set and ${$pack . '::TODO'} = $new_value; + return $old_value; } -=item B<parent> - - if ( my $parent = $builder->parent ) { - ... - } - -Returns the parent C<Test::Builder> instance, if any. Only used with child -builders for nested TAP. - -=cut - -sub parent { shift->{Parent} } - -=item B<name> - - diag $builder->name; +sub todo { + my ($self, $pack) = @_; -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<child> -method. If no name is supplied, will be named "Child of $parent->name". + return $self->{Todo} if defined $self->{Todo}; -=cut + my $ctx = $self->ctx; -sub name { shift->{Name} } + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; -sub DESTROY { - my $self = shift; - if ( $self->parent and $$ == $self->{Original_Pid} ) { - my $name = $self->name; - $self->diag(<<"FAIL"); -Child ($name) exited without calling finalize() -FAIL - $self->parent->{In_Destroy} = 1; - $self->parent->ok(0, $name); - } + return ''; } -=item B<reset> - - $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. - -=cut - -our $Level; - -sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my($self) = @_; - - # 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->{Name} = $0; - $self->is_passing(1); - $self->{Ending} = 0; - $self->{Have_Plan} = 0; - $self->{No_Plan} = 0; - $self->{Have_Output_Plan} = 0; - $self->{Done_Testing} = 0; - - $self->{Original_Pid} = $$; - $self->{Child_Name} = undef; - $self->{Indent} ||= ''; - - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share( [] ); - - $self->{Exported_To} = undef; - $self->{Expected_Tests} = 0; - - $self->{Skip_All} = 0; - - $self->{Use_Nums} = 1; - - $self->{No_Header} = 0; - $self->{No_Ending} = 0; - - $self->{Todo} = undef; - $self->{Todo_Stack} = []; - $self->{Start_Todo} = 0; - $self->{Opened_Testhandles} = 0; +sub in_todo { + my $self = shift; - $self->_share_keys; - $self->_dup_stdhandles; + my $ctx = $self->ctx; + return 1 if $ctx->in_todo; - return; + return (defined $self->{Todo} || $self->find_TODO) ? 1 : 0; } - -# Shared scalar values are lost when a hash is copied, so we have -# a separate method to restore them. -# Shared references are retained across copies. -sub _share_keys { +sub todo_start { my $self = shift; + my $message = @_ ? shift : ''; - share( $self->{Curr_Test} ); + $self->{Start_Todo}++; + if ($self->in_todo) { + push @{$self->{Todo_Stack}} => $self->todo; + } + $self->{Todo} = $message; return; } +sub todo_end { + my $self = shift; -=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<plan> - - $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 (!$self->{Start_Todo}) { + $self->ctx(-1)->throw('todo_end() called without todo_start()'); + } -If you call C<plan()>, don't call any of the other methods below. + $self->{Start_Todo}--; -If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is -thrown. Trap this error, call C<finalize()> and don't run any more tests on -the child. + if ($self->{Start_Todo} && @{$self->{Todo_Stack}}) { + $self->{Todo} = pop @{$self->{Todo_Stack}}; + } + else { + delete $self->{Todo}; + } - my $child = $Test->child('some child'); - eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) }; - if ( eval { $@->isa('Test::Builder::Exception') } ) { - $child->finalize; return; - } - # run your tests +} -=cut +##################################### +# }}} Finding Testers and Providers # +##################################### -my %plan_cmds = ( - no_plan => \&no_plan, - skip_all => \&skip_all, - tests => \&_plan_tests, +################ +# {{{ Planning # +################ + +my %PLAN_CMDS = ( + no_plan => 'no_plan', + skip_all => 'skip_all', + tests => '_plan_tests', ); sub plan { - my( $self, $cmd, $arg ) = @_; + my ($self, $cmd, @args) = @_; - return unless $cmd; + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + WARN_OF_OVERRIDE(plan => $ctx); - local $Level = $Level + 1; - - $self->croak("You tried to plan twice") if $self->{Have_Plan}; + return unless $cmd; - if( my $method = $plan_cmds{$cmd} ) { - local $Level = $Level + 1; - $self->$method($arg); + if (my $method = $PLAN_CMDS{$cmd}) { + $self->$method(@args); } else { - my @args = grep { defined } ( $cmd, $arg ); - $self->croak("plan() doesn't understand @args"); + my @in = grep { defined } ($cmd, @args); + $self->ctx->throw("plan() doesn't understand @in"); } return 1; } +sub skip_all { + my ($self, $reason) = @_; -sub _plan_tests { - my($self, $arg) = @_; - - if($arg) { - local $Level = $Level + 1; - return $self->expected_tests($arg); - } - elsif( !defined $arg ) { - $self->croak("Got an undefined number of tests"); - } - else { - $self->croak("You said to run 0 tests"); - } - - return; -} - -=item B<expected_tests> - - 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. - -=cut - -sub expected_tests { - my $self = shift; - my($max) = @_; - - if(@_) { - $self->croak("Number of tests must be a positive integer. You gave it '$max'") - unless $max =~ /^\+?\d+$/; + $self->{Skip_All} = 1; - $self->{Expected_Tests} = $max; - $self->{Have_Plan} = 1; + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - $self->_output_plan($max) unless $self->no_header; - } - return $self->{Expected_Tests}; + $ctx->_plan(0, 'SKIP', $reason); } -=item B<no_plan> - - $Test->no_plan; - -Declares that this test will run an indeterminate number of tests. - -=cut - sub no_plan { - my($self, $arg) = @_; + my ($self, @args) = @_; - $self->carp("no_plan takes no arguments") if $arg; + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - $self->{No_Plan} = 1; - $self->{Have_Plan} = 1; + $ctx->alert("no_plan takes no arguments") if @args; + $ctx->_plan(0, 'NO PLAN'); return 1; } -=begin private - -=item B<_output_plan> - - $tb->_output_plan($max); - $tb->_output_plan($max, $directive); - $tb->_output_plan($max, $directive => $reason); - -Handles displaying the test plan. - -If a C<$directive> and/or C<$reason> are given they will be output with the -plan. So here's what skipping all tests looks like: - - $tb->_output_plan(0, "SKIP", "Because I said so"); - -It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already -output. - -=end private - -=cut - -sub _output_plan { - my($self, $max, $directive, $reason) = @_; - - $self->carp("The plan was already output") if $self->{Have_Output_Plan}; - - my $plan = "1..$max"; - $plan .= " # $directive" if defined $directive; - $plan .= " $reason" if defined $reason; - - $self->_print("$plan\n"); - - $self->{Have_Output_Plan} = 1; - - return; -} - - -=item B<done_testing> - - $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<no_plan> was declared, -this will override. - -If C<done_testing()> 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<done_testing()> is, in effect, used when you'd want to use C<no_plan>, 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); +sub _plan_tests { + my ($self, $arg) = @_; -=cut + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); -sub done_testing { - my($self, $num_tests) = @_; - - # If done_testing() specified the number of tests, shut off no_plan. - if( defined $num_tests ) { - $self->{No_Plan} = 0; - } - else { - $num_tests = $self->current_test; - } + if ($arg) { + $ctx->throw("Number of tests must be a positive integer. You gave it '$arg'") + unless $arg =~ /^\+?\d+$/; - if( $self->{Done_Testing} ) { - my($file, $line) = @{$self->{Done_Testing}}[1,2]; - $self->ok(0, "done_testing() was already called at $file line $line"); - return; + $ctx->_plan($arg); } - - $self->{Done_Testing} = [caller]; - - if( $self->expected_tests && $num_tests != $self->expected_tests ) { - $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". - "but done_testing() expects $num_tests"); + elsif (!defined $arg) { + $ctx->throw("Got an undefined number of tests"); } else { - $self->{Expected_Tests} = $num_tests; + $ctx->throw("You said to run 0 tests"); } - $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; - - $self->{Have_Plan} = 1; - - # The wrong number of tests were run - $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; - - # No tests were run - $self->is_passing(0) if $self->{Curr_Test} == 0; - - return 1; + return; } +sub done_testing { + my ($self, $num_tests) = @_; -=item B<has_plan> + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + WARN_OF_OVERRIDE(done_testing => $ctx); - $plan = $Test->has_plan + my $out = $ctx->stream->done_testing($ctx, $num_tests); + return $out; +} -Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan -has been set), C<no_plan> (indeterminate # of tests) or an integer (the number -of expected tests). +################ +# }}} Planning # +################ -=cut +############################# +# {{{ Base Event Producers # +############################# -sub has_plan { +sub ok { my $self = shift; + my($test, $name) = @_; - return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; - return('no_plan') if $self->{No_Plan}; - return(undef); -} - -=item B<skip_all> - - $Test->skip_all; - $Test->skip_all($reason); + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + WARN_OF_OVERRIDE(ok => $ctx); -Skips all the tests, using the given C<$reason>. Exits immediately with 0. + if ($self->{child}) { + $self->is_passing(0); + $ctx->throw("Cannot run test ($name) with active children"); + } -=cut + $ctx->_unwind_ok($test, $name); + return $test ? 1 : 0; +} -sub skip_all { +sub BAIL_OUT { my( $self, $reason ) = @_; - - $self->{Skip_All} = $self->parent ? $reason : 1; - - $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; - if ( $self->parent ) { - die bless {} => 'Test::Builder::Exception'; - } - exit(0); + $self->ctx()->bail($reason); } -=item B<exported_to> - - 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. - -=cut - -sub exported_to { - my( $self, $pack ) = @_; +sub skip { + my( $self, $why ) = @_; + $why ||= ''; + unoverload_str( \$why ); - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{Exported_To}; + my $ctx = $self->ctx(); + $ctx->set_skip($why); + $ctx->ok(1, ''); + $ctx->set_skip(undef); } -=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<ok> - - $Test->ok($test, $name); - -Your basic test. Pass if C<$test> is true, fail if $test is false. Just -like Test::Simple's C<ok()>. - -=cut - -sub ok { - my( $self, $test, $name ) = @_; - - if ( $self->{Child_Name} and not $self->{In_Destroy} ) { - $name = 'unnamed test' unless defined $name; - $self->is_passing(0); - $self->croak("Cannot run test ($name) with active children"); - } - # $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 $self->{Curr_Test}; - $self->{Curr_Test}++; - - # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload_str( \$name ); - - $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; - You named your test '$name'. You shouldn't use numbers for your test names. - Very confusing. -ERR - - # Capture the value of $TODO for the rest of this ok() call - # so it can more easily be found by other routines. - my $todo = $self->todo(); - my $in_todo = $self->in_todo; - local $self->{Todo} = $todo if $in_todo; - - $self->_unoverload_str( \$todo ); - - my $out; - my $result = &share( {} ); - - unless($test) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); - } - - $out .= "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; - } - - if( $self->in_todo ) { - $out .= " # TODO $todo"; - $result->{reason} = $todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } +sub todo_skip { + my( $self, $why ) = @_; + $why ||= ''; + unoverload_str( \$why ); - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; - $out .= "\n"; + my $ctx = $self->ctx(); + $ctx->set_skip($why); + $ctx->set_todo($why); + $ctx->ok(0, ''); + $ctx->set_skip(undef); + $ctx->set_todo(undef); +} - $self->_print($out); +sub diag { + my $self = shift; + my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; - unless($test) { - my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; - $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + WARN_OF_OVERRIDE(diag => $ctx); - my( undef, $file, $line ) = $self->caller; - if( defined $name ) { - $self->diag(qq[ $msg test '$name'\n]); - $self->diag(qq[ at $file line $line.\n]); - } - else { - $self->diag(qq[ $msg test at $file line $line.\n]); - } - } + $ctx->_diag($msg); + return; +} - $self->is_passing(0) unless $test || $self->in_todo; +sub note { + my $self = shift; + my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; - # Check that we haven't violated the plan - $self->_check_is_passing_plan(); + my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + WARN_OF_OVERRIDE(note => $ctx); - return $test ? 1 : 0; + $ctx->_note($msg); } +############################# +# }}} Base Event Producers # +############################# -# Check that we haven't yet violated the plan and set -# is_passing() accordingly -sub _check_is_passing_plan { +####################### +# {{{ Public helpers # +####################### + +sub explain { my $self = shift; - my $plan = $self->has_plan; - return unless defined $plan; # no plan yet defined - return unless $plan !~ /\D/; # no numeric plan - $self->is_passing(0) if $plan < $self->{Curr_Test}; + return map { + ref $_ + ? do { + protect { require Data::Dumper }; + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; } - -sub _unoverload { +sub carp { my $self = shift; - my $type = shift; - - $self->_try(sub { require overload; }, die_on_fail => 1); - - foreach my $thing (@_) { - if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method( $$thing, $type ) ) { - $$thing = $$thing->$string_meth(); - } - } - } - - return; + $self->ctx->alert(join '' => @_); } -sub _is_object { - my( $self, $thing ) = @_; - - return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; +sub croak { + my $self = shift; + $self->ctx->throw(join '' => @_); } -sub _unoverload_str { +sub has_plan { my $self = shift; - return $self->_unoverload( q[""], @_ ); + my $plan = $self->ctx->stream->plan || return undef; + return 'no_plan' if $plan->directive && $plan->directive eq 'NO PLAN'; + return $plan->max; } -sub _unoverload_num { +sub reset { my $self = shift; + my %params = @_; - $self->_unoverload( '0+', @_ ); + $self->{use_shared} = 1 if $params{shared_stream}; - for my $val (@_) { - next unless $self->_is_dualvar($$val); - $$val = $$val + 0; + if ($self->{use_shared}) { + Test::Stream->shared->_reset; + Test::Stream->shared->state->[-1]->[STATE_LEGACY] = []; + } + else { + $self->{stream} = Test::Stream->new(); + $self->{stream}->set_use_legacy(1); + $self->{stream}->state->[-1]->[STATE_LEGACY] = []; } - return; -} - -# 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); -} - -=item B<is_eq> + # 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; - $Test->is_eq($got, $expected, $name); + $self->{Name} = $0; -Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the -string version. + $self->{Original_Pid} = $$; + $self->{Child_Name} = undef; -C<undef> only ever matches another C<undef>. + $self->{Exported_To} = undef; -=item B<is_num> + $self->{Todo} = undef; + $self->{Todo_Stack} = []; + $self->{Start_Todo} = 0; + $self->{Opened_Testhandles} = 0; - $Test->is_num($got, $expected, $name); + return; +} -Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the -numeric version. +####################### +# }}} Public helpers # +####################### -C<undef> only ever matches another C<undef>. +################################# +# {{{ Advanced Event Producers # +################################# -=cut +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->cmp_check($got, $type, $expect); + $ctx->ok($ok, $name, \@diag); + return $ok; +} sub is_eq { my( $self, $got, $expect, $name ) = @_; - 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; - return $test; - } - - return $self->cmp_ok( $got, 'eq', $expect, $name ); + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->is_eq($got, $expect); + $ctx->ok($ok, $name, \@diag); + return $ok; } sub is_num { my( $self, $got, $expect, $name ) = @_; - 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; - return $test; - } - - return $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 + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->is_num($got, $expect); + $ctx->ok($ok, $name, \@diag); + return $ok; } -=item B<isnt_eq> - - $Test->isnt_eq($got, $dont_expect, $name); - -Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is -the string version. - -=item B<isnt_num> - - $Test->isnt_num($got, $dont_expect, $name); - -Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is -the numeric version. - -=cut - sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; - 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; - return $test; - } - - return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->isnt_eq($got, $dont_expect); + $ctx->ok($ok, $name, \@diag); + return $ok; } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; - 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; - return $test; - } - - return $self->cmp_ok( $got, '!=', $dont_expect, $name ); + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->isnt_num($got, $dont_expect); + $ctx->ok($ok, $name, \@diag); + return $ok; } -=item B<like> - - $Test->like($thing, qr/$regex/, $name); - $Test->like($thing, '/$regex/', $name); - -Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>. - -=item B<unlike> - - $Test->unlike($thing, qr/$regex/, $name); - $Test->unlike($thing, '/$regex/', $name); - -Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the -given C<$regex>. - -=cut - sub like { my( $self, $thing, $regex, $name ) = @_; - - local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '=~', $name ); + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->regex_check($thing, $regex, '=~'); + $ctx->ok($ok, $name, \@diag); + return $ok; } sub unlike { my( $self, $thing, $regex, $name ) = @_; - - local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '!~', $name ); + my $ctx = $self->ctx; + my ($ok, @diag) = tmt->regex_check($thing, $regex, '!~'); + $ctx->ok($ok, $name, \@diag); + return $ok; } -=item B<cmp_ok> - - $Test->cmp_ok($thing, $type, $that, $name); +################################# +# }}} Advanced Event Producers # +################################# -Works just like L<Test::More>'s C<cmp_ok()>. +################################################ +# {{{ Misc # +################################################ - $Test->cmp_ok($big_num, '!=', $other_big_num); - -=cut - -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 ) = @_; - - if ($cmp_ok_bl{$type}) { - $self->croak("$type is not a valid comparison operator in cmp_ok()"); - } - - my ($test, $succ); - my $error; - { - ## no critic (BuiltinFunctions::ProhibitStringyEval) - - local( $@, $!, $SIG{__DIE__} ); # isolate eval +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; - my($pack, $file, $line) = $self->caller(); + return $file_or_fh if $self->is_fh($file_or_fh); - # 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 = $@; + my $fh; + if( ref $file_or_fh eq 'SCALAR' ) { + open $fh, ">>", $file_or_fh + or croak("Can't open scalar ref $file_or_fh: $!"); } - 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|!=)$/ ) { - $self->_isnt_diag( $got, $type ); - } - else { - $self->_cmp_diag( $got, $type, $expect ); - } + else { + open $fh, ">", $file_or_fh + or croak("Can't open test output log $file_or_fh: $!"); + Test::Stream::IOSets->_autoflush($fh); } - return $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 + return $fh; } -sub _caller_context { +sub output { 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; + my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); + $handles->[0] = $self->_new_fh(@_) if @_; + return $handles->[0]; } -=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<BAIL_OUT> - - $Test->BAIL_OUT($reason); - -Indicates to the L<Test::Harness> that things are going so badly all -testing should terminate. This includes running any additional test -scripts. - -It will exit with 255. - -=cut - -sub BAIL_OUT { - my( $self, $reason ) = @_; - - $self->{Bailed_Out} = 1; - - if ($self->parent) { - $self->{Bailed_Out_Reason} = $reason; - $self->no_ending(1); - die bless {} => 'Test::Builder::Exception'; - } - - $self->_print("Bail out! $reason"); - exit 255; +sub failure_output { + my $self = shift; + my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); + $handles->[1] = $self->_new_fh(@_) if @_; + return $handles->[1]; } -=for deprecated -BAIL_OUT() used to be BAILOUT() - -=cut - -{ - no warnings 'once'; - *BAILOUT = \&BAIL_OUT; +sub todo_output { + my $self = shift; + my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); + $handles->[2] = $self->_new_fh(@_) if @_; + return $handles->[2] || $handles->[0]; } -=item B<skip> - - $Test->skip; - $Test->skip($why); - -Skips the current test, reporting C<$why>. - -=cut - -sub skip { - my( $self, $why, $name ) = @_; - $why ||= ''; - $name = '' unless defined $name; - $self->_unoverload_str( \$why ); - - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 1, - name => $name, - type => 'skip', - reason => $why, - } - ); - - my $out = "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # skip"; - $out .= " $why" if length $why; - $out .= "\n"; - - $self->_print($out); - - return 1; +sub reset_outputs { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->io_sets->reset_legacy; } -=item B<todo_skip> - - $Test->todo_skip; - $Test->todo_skip($why); - -Like C<skip()>, only it will declare the test as failing and TODO. Similar -to - - print "not ok $tnum # TODO $why\n"; - -=cut - -sub todo_skip { - my( $self, $why ) = @_; - $why ||= ''; - - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - } - ); - - my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; - - $self->_print($out); - - return 1; +sub use_numbers { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->set_use_numbers(@_) if @_; + $ctx->stream->use_numbers; } -=begin _unimplemented - -=item B<skip_rest> - - $Test->skip_rest; - $Test->skip_rest($reason); - -Like C<skip()>, only it skips all the rest of the tests you plan to run -and terminates the test. - -If you're running under C<no_plan>, 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<maybe_regex> - - $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<qr//>, or a string -representing a regular expression. - -Returns a Perl value which may be used instead of the corresponding -regular expression, or C<undef> if its argument is not recognised. - -For example, a version of C<like()>, 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); - } - -=cut - -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 no_ending { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->set_no_ending(@_) if @_; + $ctx->stream->no_ending || 0; } -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 no_header { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->set_no_header(@_) if @_; + $ctx->stream->no_header || 0; } -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 no_diag { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->set_no_diag(@_) if @_; + $ctx->stream->no_diag || 0; } -# I'm not ready to publish this. It doesn't deal with array return -# values from the code or context. - -=begin private - -=item B<_try> - - my $return_from_code = $Test->try(sub { code }); - my($return_from_code, $error) = $Test->try(sub { code }); - -Works like eval BLOCK except it ensures it has no effect on the rest -of the test (ie. C<$@> is not set) nor is effected by outside -interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older -Perls. - -C<$error> is what would normally be in C<$@>. - -It is suggested you use this in place of eval BLOCK. - -=cut - -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 exported_to { + my($self, $pack) = @_; + $self->{Exported_To} = $pack if defined $pack; + return $self->{Exported_To}; } -=end private - - -=item B<is_fh> - - my $is_fh = $Test->is_fh($thing); - -Determines if the given C<$thing> can be used as a filehandle. - -=cut - sub is_fh { my $self = shift; my $maybe_fh = shift; @@ -1552,1121 +701,548 @@ sub is_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') }; -} - -=back - - -=head2 Test style - - -=over 4 - -=item B<level> - - $Test->level($how_high); - -How far up the call stack should C<$Test> look when reporting where the -test failed. - -Defaults to 1. - -Setting L<$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. - -=cut - -sub level { - my( $self, $level ) = @_; - - if( defined $level ) { - $Level = $level; - } - return $Level; -} - -=item B<use_numbers> - - $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. - -=cut - -sub use_numbers { - my( $self, $use_nums ) = @_; - - if( defined $use_nums ) { - $self->{Use_Nums} = $use_nums; - } - return $self->{Use_Nums}; -} - -=item B<no_diag> - - $Test->no_diag($no_diag); - -If set true no diagnostics will be printed. This includes calls to -C<diag()>. - -=item B<no_ending> - - $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<no_header> - - $Test->no_header($no_header); - -If set to true, no "1..N" header will be printed. - -=cut - -foreach my $attribute (qw(No_Header No_Ending No_Diag)) { - my $method = lc $attribute; - - my $code = sub { - my( $self, $no ) = @_; - - if( defined $no ) { - $self->{$attribute} = $no; - } - return $self->{$attribute}; + my $out; + protect { + $out = eval { $maybe_fh->isa("IO::Handle") } + || eval { tied($maybe_fh)->can('TIEHANDLE') }; }; - no strict 'refs'; ## no critic - *{ __PACKAGE__ . '::' . $method } = $code; + return $out; } -=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<diag> - - $Test->diag(@msgs); - -Prints out the given C<@msgs>. Like C<print>, arguments are simply -appended together. - -Normally, it uses the C<failure_output()> handle, but if this is for a -TODO test, the C<todo_output()> 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<diag()> is often used in conjunction with -a failing test (C<ok() || diag()>) it "passes through" the failure. - - return ok(...) || diag(...); +sub BAILOUT { goto &BAIL_OUT } -=for blame transfer -Mark Fowler <mark@twoshortplanks.com> - -=cut - -sub diag { +sub expected_tests { my $self = shift; - $self->_print_comment( $self->_diag_fh, @_ ); -} - -=item B<note> - - $Test->note(@msgs); + my $ctx = $self->ctx; + $ctx->plan(@_) if @_; -Like C<diag()>, but it prints to the C<output()> handle so it will not -normally be seen by the user except in verbose mode. - -=cut - -sub note { - my $self = shift; - - $self->_print_comment( $self->output, @_ ); + my $plan = $ctx->stream->state->[-1]->[STATE_PLAN] || return 0; + return $plan->max || 0; } -sub _diag_fh { +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my $self = shift; - local $Level = $Level + 1; - return $self->in_todo ? $self->todo_output : $self->failure_output; -} - -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; + my $ctx = $self->ctx; - # Escape the beginning, _print will take care of the rest. - $msg =~ s/^/# /; - - local $Level = $Level + 1; - $self->_print_to_fh( $fh, $msg ); - - return 0; + return wantarray ? $ctx->call : $ctx->package; } -=item B<explain> - - 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; - -=cut - -sub explain { - my $self = shift; - - return map { - ref $_ - ? do { - $self->_try(sub { require Data::Dumper }, die_on_fail => 1); - - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @_; +sub level { + my( $self, $level ) = @_; + $Level = $level if defined $level; + return $Level; } -=begin _private - -=item B<_print> - - $Test->_print(@msgs); - -Prints to the C<output()> filehandle. - -=end _private - -=cut - -sub _print { - my $self = shift; - return $self->_print_to_fh( $self->output, @_ ); +sub maybe_regex { + my ($self, $regex) = @_; + return is_regex($regex); } -sub _print_to_fh { - my( $self, $fh, @msgs ) = @_; - - # Prevent printing headers when only compiling. Mostly for when - # tests are deparsed with B::Deparse - return if $^C; - - my $msg = join '', @msgs; - my $indent = $self->_indent; - - local( $\, $", $, ) = ( undef, ' ', '' ); - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n$indent# }sg; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\z/; - - return print $fh $indent, $msg; +sub is_passing { + my $self = shift; + my $ctx = $self->ctx; + $ctx->stream->is_passing(@_); } -=item B<output> - -=item B<failure_output> - -=item B<todo_output> - - 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<output> is where normal "ok/not ok" test output goes. - -Defaults to STDOUT. - -B<failure_output> is where diagnostic output on test failures and -C<diag()> goes. It is normally not read by Test::Harness and instead is -displayed to the user. - -Defaults to STDERR. - -C<todo_output> is used instead of C<failure_output()> for the -diagnostics of a failing TODO test. These will not be seen by the -user. - -Defaults to STDOUT. - -=cut - -sub output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Out_FH} = $self->_new_fh($fh); - } - return $self->{Out_FH}; -} +# Yeah, this is not efficient, but it is only legacy support, barely anything +# uses it, and they really should not. +sub current_test { + my $self = shift; -sub failure_output { - my( $self, $fh ) = @_; + my $ctx = $self->ctx; + + if (@_) { + my ($num) = @_; + my $state = $ctx->stream->state->[-1]; + $state->[STATE_COUNT] = $num; + + my $old = $state->[STATE_LEGACY] || []; + my $new = []; + + my $nctx = $ctx->snapshot; + $nctx->set_todo('incrementing test number'); + $nctx->set_in_todo(1); + + for (1 .. $num) { + my $i; + $i = shift @$old while @$old && (!$i || !$i->isa('Test::Stream::Event::Ok')); + $i ||= Test::Stream::Event::Ok->new( + $nctx, + [CORE::caller()], + 0, + undef, + undef, + undef, + 1, + ); + + push @$new => $i; + } - if( defined $fh ) { - $self->{Fail_FH} = $self->_new_fh($fh); + $state->[STATE_LEGACY] = $new; } - return $self->{Fail_FH}; -} -sub todo_output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Todo_FH} = $self->_new_fh($fh); - } - return $self->{Todo_FH}; + $ctx->stream->count; } -sub _new_fh { +sub details { my $self = shift; - my($file_or_fh) = shift; + my $ctx = $self->ctx; + my $state = $ctx->stream->state->[-1]; + my @out; + return @out unless $state->[STATE_LEGACY]; - 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"); - } + for my $e (@{$state->[STATE_LEGACY]}) { + next unless $e && $e->isa('Test::Stream::Event::Ok'); + push @out => $e->to_legacy; } - 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; + return @out; } -my( $Testout, $Testerr ); - -sub _dup_stdhandles { +sub summary { my $self = shift; - - $self->_open_testhandles; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush($Testout); - _autoflush( \*STDOUT ); - _autoflush($Testerr); - _autoflush( \*STDERR ); - - $self->reset_outputs; - - return; + my $ctx = $self->ctx; + my $state = $ctx->stream->state->[-1]; + return @{[]} unless $state->[STATE_LEGACY]; + return map { $_->isa('Test::Stream::Event::Ok') ? ($_->bool ? 1 : 0) : ()} @{$state->[STATE_LEGACY]}; } -sub _open_testhandles { - my $self = shift; +################################### +# }}} Misc # +################################### - return if $self->{Opened_Testhandles}; +#################### +# {{{ TB1.5 stuff # +#################### - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; - open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; +# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does. +my %TB15_METHODS = map { $_ => 1 } qw{ + _file_and_line _join_message _make_default _my_exit _reset_todo_state + _result_to_hash _results _todo_state formatter history in_test + no_change_exit_code post_event post_result set_formatter set_plan test_end + test_exit_code test_start test_state +}; - $self->_copy_io_layers( \*STDOUT, $Testout ); - $self->_copy_io_layers( \*STDERR, $Testerr ); +our $AUTOLOAD; - $self->{Opened_Testhandles} = 1; +sub AUTOLOAD { + $AUTOLOAD =~ m/^(.*)::([^:]+)$/; + my ($package, $sub) = ($1, $2); - return; -} + my @caller = CORE::caller(); + my $msg = qq{Can't locate object method "$sub" via package "$package" at $caller[1] line $caller[2].\n}; -sub _copy_io_layers { - my( $self, $src, $dst ) = @_; + $msg .= <<" EOT" if $TB15_METHODS{$sub}; - $self->_try( - sub { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); + ************************************************************************* + '$sub' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch. + You need to update your code so that it no longer treats Test::Builders + over a specific version number as anything special. - _apply_layers($dst, @src_layers) if @src_layers; - } - ); - - return; -} + See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html + ************************************************************************* + EOT -sub _apply_layers { - my ($fh, @layers) = @_; - my %seen; - my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; - binmode($fh, join(":", "", "raw", @unique)); + die $msg; } +#################### +# }}} TB1.5 stuff # +#################### -=item reset_outputs - - $tb->reset_outputs; - -Resets all the output filehandles back to their defaults. - -=cut - -sub reset_outputs { - my $self = shift; - - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); - - return; -} +1; -=item carp +__END__ - $tb->carp(@message); +=pod -Warns with C<@message> but the message will appear to come from the -point where the original test function was called (C<< $tb->caller >>). +=head1 NAME -=item croak +Test::Builder - *DEPRECATED* Module for building testing libraries. - $tb->croak(@message); +=head1 DESCRIPTION -Dies with C<@message> but the message will appear to come from the -point where the original test function was called (C<< $tb->caller >>). +This module was previously the base module for almost any testing library. This +module is now little more than a compatability wrapper around L<Test::Stream>. +If you are looking to write or update a testing library you should look at +L<Test::Stream::Toolset>. -=cut +=head1 PACKAGE VARS -sub _message_at_caller { - my $self = shift; +=over 4 - local $Level = $Level + 1; - my( $pack, $file, $line ) = $self->caller; - return join( "", @_ ) . " at $file line $line.\n"; -} +=item $Test::Builder::Test -sub carp { - my $self = shift; - return warn $self->_message_at_caller(@_); -} +The variable that holds the Test::Builder singleton. -sub croak { - my $self = shift; - return die $self->_message_at_caller(@_); -} +=item $Test::Builder::Level +In the past this variable was used to track stack depth so that Test::Builder +could report the correct line number. If you use Test::Builder this will still +work, but in new code it is better to use the L<Test::Stream::Context> module. =back +=head1 METHODS -=head2 Test Status and Info +=head2 CONSTRUCTORS =over 4 -=item B<current_test> +=item Test::Builder->new - my $curr_test = $Test->current_test; - $Test->current_test($num); +Returns the singleton stored in C<$Test::Builder::Test>. -Gets/sets the current test number we're on. You usually shouldn't -have to set this. +=item Test::Builder->create -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 Test::Builder->create(use_shared => 1) -=cut +Returns a new instance of Test::Builder. It is important to note that this +instance will not use the shared L<Test::Stream> object unless you pass in the +C<< use_shared => 1 >> argument. -sub current_test { - my( $self, $num ) = @_; - - lock( $self->{Curr_Test} ); - if( defined $num ) { - $self->{Curr_Test} = $num; - - # If the test counter is being pushed forward fill in the details. - my $test_results = $self->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for( $start .. $num - 1 ) { - $test_results->[$_] = &share( - { - '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 $self->{Curr_Test}; -} +=back -=item B<is_passing> +=head2 UTIL - my $ok = $builder->is_passing; +=over 4 -Indicates if the test suite is currently passing. +=item $TB->ctx -More formally, it will be false if anything has happened which makes -it impossible for the test suite to pass. True otherwise. +Helper method for Test::Builder to get a L<Test::Stream::Context> object. -For example, if no tests have run C<is_passing()> 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. +=item $TB->depth -Don't think about it too much. +Get the subtest depth -=cut +=item $TB->find_TODO -sub is_passing { - my $self = shift; +=item $TB->in_todo - if( @_ ) { - $self->{Is_Passing} = shift; - } +=item $TB->todo - return $self->{Is_Passing}; -} +These all check on todo state and value +=back -=item B<summary> +=head2 OTHER - my @tests = $Test->summary; +=over 4 -A simple summary of the tests so far. True for pass, false for fail. -This is a logical pass/fail, so todos are passes. +=item $TB->caller -Of course, test #1 is $tests[0], etc... +=item $TB->carp -=cut +=item $TB->croak -sub summary { - my($self) = shift; +These let you figure out when/where the test is defined in the test file. - return map { $_->{'ok'} } @{ $self->{Test_Results} }; -} +=item $TB->child -=item B<details> +Start a subtest (Please do not use this) - my @tests = $Test->details; +=item $TB->finalize -Like C<summary()>, but with a lot more detail. +Finish a subtest (Please do not use this) - $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) - }; +=item $TB->explain -'ok' is true if Test::Harness will consider the test to be a pass. +Interface to Data::Dumper that dumps whatever you give it. -'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. +=item $TB->exported_to -'name' is the name of the test. +This used to tell you what package used Test::Builder, it never worked well. +The previous bad and unpredictable behavior of this has largely been preserved, +however nothing internal uses it in any meaningful way anymore. -'type' indicates if it was a special test. Normal tests have a type -of ''. Type can be one of the following: +=item $TB->is_fh - skip see skip() - todo see todo() - todo_skip see todo_skip() - unknown see below +Check if something is a filehandle -Sometimes the Test::Builder test counter is incremented without it -printing any test output, for example, when C<current_test()> 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<undef>. +=item $TB->level -For example "not ok 23 - hole count # TODO insufficient donuts" would -result in this structure: +Get/Set C<$Test::Builder::Level>. $Level is a package var, and most thigns +localize it, so this method is pretty useless. - $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 $TB->maybe_regex -=cut +Check if something might be a regex. -sub details { - my $self = shift; - return @{ $self->{Test_Results} }; -} +=item $TB->reset -=item B<todo> +Reset the builder object to a very basic and default state. You almost +certainly do not need this unless you are writing a tool to test testing +libraries. Even then you probably do not want this. - my $todo_reason = $Test->todo; - my $todo_reason = $Test->todo($pack); +=item $TB->todo_end -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<todo_start()>. +=item $TB->todo_start -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. +Start/end TODO state, there are better ways to do this now. -C<todo()> 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<todo()> is usually called inside -a test function. As a last resort it will use C<exported_to()>. +=back -Sometimes there is some confusion about where C<todo()> should be looking -for the C<$TODO> variable. If you want to be sure, tell it explicitly -what $pack to use. +=head2 STREAM INTERFACE -=cut +These simply interface into functionality of L<Test::Stream>. -sub todo { - my( $self, $pack ) = @_; +=over 4 - return $self->{Todo} if defined $self->{Todo}; +=item $TB->failure_output - local $Level = $Level + 1; - my $todo = $self->find_TODO($pack); - return $todo if defined $todo; +=item $TB->output - return ''; -} +=item $TB->reset_outputs -=item B<find_TODO> +=item $TB->todo_output - my $todo_reason = $Test->find_TODO(); - my $todo_reason = $Test->find_TODO($pack); +These get/set the IO handle used in the 'legacy' tap encoding. -Like C<todo()> but only returns the value of C<$TODO> ignoring -C<todo_start()>. +=item $TB->no_diag -Can also be used to set C<$TODO> to a new value while returning the -old value: +Do not display L<Test::Stream::Event::Diag> events. - my $old_reason = $Test->find_TODO($pack, 1, $new_reason); +=item $TB->no_ending -=cut +Do not do some special magic at the end that tells you what went wrong with +tests. -sub find_TODO { - my( $self, $pack, $set, $new_value ) = @_; +=item $TB->no_header - $pack = $pack || $self->caller(1) || $self->exported_to; - return unless $pack; +Do not display the plan - no strict 'refs'; ## no critic - my $old_value = ${ $pack . '::TODO' }; - $set and ${ $pack . '::TODO' } = $new_value; - return $old_value; -} +=item $TB->use_numbers -=item B<in_todo> +Turn numbers in TAP on and off. - my $in_todo = $Test->in_todo; +=back -Returns true if the test is currently inside a TODO block. +=head2 HISTORY -=cut +=over -sub in_todo { - my $self = shift; +=item $TB->details - local $Level = $Level + 1; - return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; -} +Get all the events that occured on this object. Each event will be transformed +into a hash that matches the legacy output of this method. -=item B<todo_start> +=item $TB->expected_tests - $Test->todo_start(); - $Test->todo_start($message); +Set/Get expected number of tests -This method allows you declare all subsequent tests as TODO tests, up until -the C<todo_end> method has been called. +=item $TB->has_plan -The C<TODO:> 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). +Check if there is a plan -Note that you can use this to nest "todo" tests +=item $TB->summary - $Test->todo_start('working on this'); - # lots of code - $Test->todo_start('working on that'); - # more code - $Test->todo_end; - $Test->todo_end; +List of pass/fail results. -This is generally not recommended, but large testing systems often have weird -internal needs. +=back -We've tried to make this also work with the TODO: syntax, but it's not -guaranteed and its use is also discouraged: +=head2 EVENT GENERATORS - 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; - } +See L<Test::Stream::Context>, L<Test::Stream::Toolset>, and +L<Test::More::Tools>. Calling the methods below is not advised. -Pick one style or another of "TODO" to be on the safe side. +=over 4 -=cut +=item $TB->BAILOUT -sub todo_start { - my $self = shift; - my $message = @_ ? shift : ''; +=item $TB->BAIL_OUT - $self->{Start_Todo}++; - if( $self->in_todo ) { - push @{ $self->{Todo_Stack} } => $self->todo; - } - $self->{Todo} = $message; +=item $TB->cmp_ok - return; -} +=item $TB->current_test -=item C<todo_end> +=item $TB->diag - $Test->todo_end; +=item $TB->done_testing -Stops running tests as "TODO" tests. This method is fatal if called without a -preceding C<todo_start> method call. +=item $TB->is_eq -=cut +=item $TB->is_num -sub todo_end { - my $self = shift; +=item $TB->is_passing - if( !$self->{Start_Todo} ) { - $self->croak('todo_end() called without todo_start()'); - } +=item $TB->isnt_eq - $self->{Start_Todo}--; +=item $TB->isnt_num - if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { - $self->{Todo} = pop @{ $self->{Todo_Stack} }; - } - else { - delete $self->{Todo}; - } +=item $TB->like - return; -} +=item $TB->no_plan -=item B<caller> +=item $TB->note - my $package = $Test->caller; - my($pack, $file, $line) = $Test->caller; - my($pack, $file, $line) = $Test->caller($height); +=item $TB->ok -Like the normal C<caller()>, except it reports according to your C<level()>. +=item $TB->plan -C<$height> will be added to the C<level()>. +=item $TB->skip -If C<caller()> winds up off the top of the stack it report the highest context. +=item $TB->skip_all -=cut +=item $TB->subtest -sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my( $self, $height ) = @_; - $height ||= 0; - - my $level = $self->level + $height + 1; - my @caller; - do { - @caller = CORE::caller( $level ); - $level--; - } until @caller; - return wantarray ? @caller : $caller[0]; -} +=item $TB->todo_skip -=back +=item $TB->unlike -=cut +=back -=begin _private +=head2 ACCESSORS =over 4 -=item B<_sanity_check> - - $self->_sanity_check(); +=item $TB->stream -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. +Get the stream used by this builder (or the shared stream). -=cut +=item $TB->name -#'# -sub _sanity_check { - my $self = shift; +Name of the test - $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); - $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!' ); +=item $TB->parent - return; -} +Parent if this is a child. -=item B<_whoa> +=back - $self->_whoa($check, $description); +=head1 MONKEYPATCHING -A sanity check, similar to C<assert()>. If the C<$check> is true, something -has gone horribly wrong. It will die with the given C<$description> and -a note to contact the author. +Many legacy testing modules monkeypatch C<ok()>, C<plan()>, and others. The +abillity to monkeypatch these to effect all events of the specified type is now +considered discouraged. For backwords compatability monkeypatching continues to +work, however in the distant future it will be removed. L<Test::Stream> upon +which Test::Builder is now built, provides hooks and API's for doing everything +that previously required monkeypatching. -=cut +=encoding utf8 -sub _whoa { - my( $self, $check, $desc ) = @_; - if($check) { - local $Level = $Level + 1; - $self->croak(<<"WHOA"); -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } +=head1 TUTORIALS - return; -} +=over 4 -=item B<_my_exit> +=item L<Test::Tutorial> - _my_exit($exit_num); +The original L<Test::Tutorial>. Uses comedy to introduce you to testing from +scratch. -Perl seems to have some trouble with exiting inside an C<END> block. -5.6.1 does some odd things. Instead, this function edits C<$?> -directly. It should B<only> be called from inside an C<END> block. -It doesn't actually exit, that's your job. +=item L<Test::Tutorial::WritingTests> -=cut +The L<Test::Tutorial::WritingTests> tutorial takes a more technical approach. +The idea behind this tutorial is to give you a technical introduction to +testing that can easily be used as a reference. This is for people who say +"Just tell me how to do it, and quickly!". -sub _my_exit { - $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) +=item L<Test::Tutorial::WritingTools> - return 1; -} +The L<Test::Tutorial::WritingTools> tutorial is an introduction to writing +testing tools that play nicely with other L<Test::Stream> and L<Test::Builder> +based tools. This is what you should look at if you want to write +Test::MyWidget. =back -=end _private - -=cut - -sub _ending { - my $self = shift; - return if $self->no_ending; - return if $self->{Ending}++; - - my $real_exit_code = $?; +=head1 SOURCE - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - if( $self->{Original_Pid} != $$ ) { - return; - } +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. - # Ran tests but never declared a plan or hit done_testing - if( !$self->{Have_Plan} and $self->{Curr_Test} ) { - $self->is_passing(0); - $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 $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } +=head1 MAINTAINER - # But if the tests ran, handle exit code. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - if ($num_failed > 0) { +=over 4 - my $exit_code = $num_failed <= 254 ? $num_failed : 254; - _my_exit($exit_code) && return; - } - } - _my_exit(254) && return; - } +=item Chad Granum E<lt>exodist@cpan.orgE<gt> - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - if( !$self->{Have_Plan} ) { - return; - } +=back - # Don't do an ending if we bailed out. - if( $self->{Bailed_Out} ) { - $self->is_passing(0); - return; - } - # Figure out if we passed or failed and print helpful messages. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - # The plan? We have no plan. - if( $self->{No_Plan} ) { - $self->_output_plan($self->{Curr_Test}) unless $self->no_header; - $self->{Expected_Tests} = $self->{Curr_Test}; - } +=head1 AUTHORS - # Auto-extended arrays and elements which aren't explicitly - # filled in with a shared reference will puke under 5.8.0 - # ithreads. So we have to fill them in by hand. :( - my $empty_result = &share( {} ); - for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { - $test_results->[$idx] = $empty_result - unless defined $test_results->[$idx]; - } +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; +=over 4 - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; +=item Chad Granum E<lt>exodist@cpan.orgE<gt> - if( $num_extra != 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. -FAIL - $self->is_passing(0); - } +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> - if($num_failed) { - my $num_tests = $self->{Curr_Test}; - my $s = $num_failed == 1 ? '' : 's'; +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> - my $qualifier = $num_extra == 0 ? '' : ' run'; +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> - $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $num_tests$qualifier. -FAIL - $self->is_passing(0); - } +=item 唐鳳 - if($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } +=back - my $exit_code; - if($num_failed) { - $exit_code = $num_failed <= 254 ? $num_failed : 254; - } - elsif( $num_extra != 0 ) { - $exit_code = 255; - } - else { - $exit_code = 0; - } +=head1 COPYRIGHT - _my_exit($exit_code) && return; - } - elsif( $self->{Skip_All} ) { - _my_exit(0) && return; - } - elsif($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code before it could output anything. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - else { - $self->diag("No tests run!\n"); - $self->is_passing(0); - _my_exit(255) && return; - } +There has been a lot of code migration between modules, +here are all the original copyrights together: - $self->is_passing(0); - $self->_whoa( 1, "We fell off the end of _ending()" ); -} +=over 4 -END { - $Test->_ending if defined $Test; -} +=item Test::Stream -=head1 EXIT CODES +=item Test::Stream::Tester -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. +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. -So the exit codes are... +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. - 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) +See F<http://www.perl.com/perl/misc/Artistic.html> -If you fail more than 254 tests, it will be reported as 254. +=item Test::Simple -=head1 THREADS +=item Test::More -In perl 5.8.1 and later, Test::Builder is thread-safe. The test -number is shared amongst all threads. This means if one thread sets -the test number using C<current_test()> they will all be effected. +=item Test::Builder -While versions earlier than 5.8.1 had threads they contain too many -bugs to support. +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. -Test::Builder is only thread-aware if threads.pm is loaded I<before> -Test::Builder. +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. -=head1 MEMORY +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. -An informative hash, accessible via C<details()>, 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. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. -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<fail()> should anything go unexpected. +See F<http://www.perl.com/perl/misc/Artistic.html> -Future versions of Test::Builder will have a way to turn history off. +=item Test::use::ok +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. -=head1 EXAMPLES +This work is published from Taiwan. -CPAN can provide the best examples. L<Test::Simple>, L<Test::More>, -L<Test::Exception> and L<Test::Differences> all use Test::Builder. +L<http://creativecommons.org/publicdomain/zero/1.0> -=head1 SEE ALSO +=item Test::Tester -L<Test::Simple>, L<Test::More>, L<Test::Harness> +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. -=head1 AUTHORS +Under the same license as Perl itself -Original code by chromatic, maintained by Michael G Schwern -E<lt>schwern@pobox.comE<gt> +See http://www.perl.com/perl/misc/Artistic.html -=head1 MAINTAINERS +=item Test::Builder::Tester -=over 4 +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. -=item Chad Granum E<lt>exodist@cpan.orgE<gt> +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. =back - -=head1 COPYRIGHT - -Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and - Michael G Schwern E<lt>schwern@pobox.comE<gt>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F<http://www.perl.com/perl/misc/Artistic.html> - -=cut - -1; - diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index 461a2ed439..dbdb1df541 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -2,18 +2,24 @@ package Test::Builder::Module; use strict; +use Test::Stream 1.301001 '-internal'; use Test::Builder 0.99; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.001009'; +our $VERSION = '1.301001_071'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) =head1 NAME -Test::Builder::Module - Base class for test modules +Test::Builder::Module - *DEPRECATED* Base class for test modules + +=head1 DEPRECATED + +B<This module is deprecated> See L<Test::Stream::Toolset> for what you should +use instead. =head1 SYNOPSIS @@ -29,12 +35,15 @@ Test::Builder::Module - Base class for test modules my $tb = $CLASS->builder; return $tb->ok(@_); } - + 1; =head1 DESCRIPTION +B<This module is deprecated> See L<Test::Stream::Toolset> for what you should +use instead. + This is a superclass for L<Test::Builder>-based modules. It provides a handful of common functionality and a method of getting at the underlying L<Test::Builder> object. @@ -56,8 +65,8 @@ same basic way as L<Test::More>'s, setting the plan and controlling exporting of functions and variables. This allows your module to set the plan independent of L<Test::More>. -All arguments passed to C<import()> are passed onto -C<< Your::Module->builder->plan() >> with the exception of +All arguments passed to C<import()> 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; @@ -76,12 +85,14 @@ C<import_extra()>. sub import { my($class) = shift; + my $test = $class->builder; + my $caller = caller; + + warn __PACKAGE__ . " is deprecated!\n" if $caller->can('TB_INSTANCE') && $caller->TB_INSTANCE->modern; + # 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); @@ -171,3 +182,105 @@ sub builder { } 1; + +__END__ + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 5dd8436d75..a323acd64d 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,17 +1,24 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.24"; +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Builder 0.98; +use Test::Stream 1.301001 '-internal'; +use Test::Builder 1.301001; use Symbol; -use Carp; +use Test::Stream::Carp qw/croak/; =head1 NAME -Test::Builder::Tester - test testsuites that have been built with +Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with Test::Builder +=head1 DEPRECATED + +B<This module is deprecated.> Please see L<Test::Stream::Tester> for a +better alternative that does not involve dealing with TAP/string output. + =head1 SYNOPSIS use Test::Builder::Tester tests => 1; @@ -48,37 +55,55 @@ output. # set up testing #### -my $t = Test::Builder->new; +#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); +use Test::Stream::Toolset; +use Test::Stream::Exporter; +default_exports qw/test_out test_err test_fail test_diag test_test line_num/; +Test::Stream::Exporter->cleanup; -sub import { +sub before_import { my $class = shift; - my(@plan) = @_; + my ($importer, $list) = @_; - my $caller = caller; + my $meta = init_tester($importer); + my $context = context(1); + my $other = []; + my $idx = 0; - $t->exported_to($caller); - $t->plan(@plan); + while ($idx <= $#{$list}) { + my $item = $list->[$idx++]; + next unless $item; - my @imports = (); - foreach my $idx ( 0 .. $#plan ) { - if( $plan[$idx] eq 'import' ) { - @imports = @{ $plan[ $idx + 1 ] }; - last; + if (defined $item and $item eq 'no_diag') { + Test::Stream->shared->set_no_diag(1); + } + elsif ($item eq 'tests') { + $context->plan($list->[$idx++]); + } + elsif ($item eq 'skip_all') { + $context->plan(0, 'SKIP', $list->[$idx++]); + } + elsif ($item eq 'no_plan') { + $context->plan(0, 'NO PLAN'); + } + elsif ($item eq 'import') { + push @$other => @{$list->[$idx++]}; } } - __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); + @$list = @$other; + + return; } + +sub builder { Test::Builder->new } + ### # set up file handles ### @@ -100,6 +125,9 @@ my $testing = 0; my $testing_num; my $original_is_passing; +my $original_stream; +my $original_state; + # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; @@ -114,15 +142,18 @@ sub _start_testing { $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; + $original_stream = builder->{stream} || Test::Stream->shared; + $original_state = [@{$original_stream->state->[-1]}]; + # 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_output_handle = builder()->output(); + $original_failure_handle = builder()->failure_output(); + $original_todo_handle = builder()->todo_output(); # switch out to our own handles - $t->output($output_handle); - $t->failure_output($error_handle); - $t->todo_output($output_handle); + builder()->output($output_handle); + builder()->failure_output($error_handle); + builder()->todo_output($output_handle); # clear the expected list $out->reset(); @@ -130,13 +161,13 @@ sub _start_testing { # 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); + $testing_num = builder()->current_test; + builder()->current_test(0); + $original_is_passing = builder()->is_passing; + builder()->is_passing(1); # look, we shouldn't do the ending stuff - $t->no_ending(1); + builder()->no_ending(1); } =head2 Functions @@ -174,6 +205,7 @@ output filehandles) =cut sub test_out { + my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -181,6 +213,7 @@ sub test_out { } sub test_err { + my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -214,6 +247,7 @@ more simply as: =cut sub test_fail { + my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -256,12 +290,13 @@ without the newlines. =cut sub test_diag { + my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; - $err->expect( map { "# $_" } @_ ); + $err->expect( map { m/\S/ ? "# $_" : "" } @_ ); } =item test_test @@ -304,6 +339,7 @@ will function normally and cause success/errors for L<Test::Harness>. =cut sub test_test { + my $ctx = context; # decode the arguments as described in the pod my $mess; my %args; @@ -322,21 +358,23 @@ sub test_test { unless $testing; # 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); + builder()->output($original_output_handle); + builder()->failure_output($original_failure_handle); + builder()->todo_output($original_todo_handle); # restore the test no, etc, back to the original point - $t->current_test($testing_num); + builder()->current_test($testing_num); $testing = 0; - $t->is_passing($original_is_passing); + builder()->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; + $original_stream->state->[-1] = $original_state; + # check the output we've stashed - unless( $t->ok( ( $args{skip_out} || $out->check ) && - ( $args{skip_err} || $err->check ), $mess ) + unless( builder()->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this @@ -344,10 +382,10 @@ sub test_test { local $_; - $t->diag( map { "$_\n" } $out->complaint ) + builder()->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; - $t->diag( map { "$_\n" } $err->complaint ) + builder()->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } @@ -418,48 +456,114 @@ sub color { =back -=head1 BUGS +=head1 NOTES -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. +Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting +me use his testing system to try this module out on. -The color function doesn't work unless L<Term::ANSIColor> is -compatible with your terminal. +=head1 SEE ALSO -Bugs (and requests for new features) can be reported to the author -though the CPAN RT system: -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester> +L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. -=head1 AUTHOR +=encoding utf8 -Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. +=head1 SOURCE -Some code taken from L<Test::More> and L<Test::Catch>, written by -Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts -Copyright Micheal G Schwern 2001. Used and distributed with -permission. +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> -=head1 MAINTAINERS +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + =back -=head1 NOTES +=head1 COPYRIGHT -Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting -me use his testing system to try this module out on. +There has been a lot of code migration between modules, +here are all the original copyrights together: -=head1 SEE ALSO +=over 4 -L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back =cut @@ -487,8 +591,10 @@ sub expect { sub _account_for_subtest { my( $self, $check ) = @_; + my $ctx = Test::Stream::Context::context(); + my $depth = @{$ctx->stream->subtests}; # Since we ship with Test::Builder, calling a private method is safe...ish. - return ref($check) ? $check : $t->_indent . $check; + return ref($check) ? $check : ($depth ? ' ' x $depth : '') . $check; } sub _translate_Failed_check { diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 4cb3b15ed9..1c1b2f5232 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,8 +1,10 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = "1.24"; +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +use Test::Stream 1.301001 '-internal'; require Test::Builder::Tester; @@ -49,3 +51,105 @@ L<Test::Builder::Tester>, L<Term::ANSIColor> =cut 1; + +__END__ + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/FAQ.pod b/cpan/Test-Simple/lib/Test/FAQ.pod new file mode 100644 index 0000000000..232ec99b26 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/FAQ.pod @@ -0,0 +1,477 @@ +=head1 NAME + +Test::FAQ - Frequently Asked Questions about testing with Perl + +=head1 DESCRIPTION + +Frequently Asked Questions about testing in general and specific +issues with Perl. + +=head2 Is there any tutorial on testing? + +L<Test::Tutorial> + +=head2 Are there any modules for testing? + +A whole bunch. Start with L<Test::Simple> then move onto Test::More. + +Then go onto L<http://search.cpan.org> and search for "Test". + +Also check out L<Fennec>. + +=head2 Are there any modules for testing web pages/CGI programs? + +L<Test::WWW::Mechanize>, L<Test::WWW::Selenium> + +=head2 Are there any modules for testing external programs? + +L<Test::Cmd> + +=head2 Can you do xUnit/JUnit style testing in Perl? + +Yes, L<Test::Class> allows you to write test methods while continuing to +use all the usual CPAN testing modules. It is the best and most +perlish way to do xUnit style testing. + +L<Test::Unit> is a more direct port of XUnit to Perl, but it does not use +the Perl conventions and does not play well with other CPAN testing +modules. As of this writing, it is abandoned. B<Do not use>. + +The L<Test::Inline> (aka L<Pod::Tests>) is worth mentioning as it allows you to +put tests into the POD in the same file as the code. + + +=head2 How do I test my module is backwards/forwards compatible? + +First, install a bunch of perls of commonly used versions. At the +moment, you could try these + + 5.7.2 + 5.6.1 + 5.005_03 + 5.004_05 + +if you're feeling brave, you might want to have on hand these + + bleadperl + 5.6.0 + 5.004_04 + 5.004 + +going back beyond 5.003 is probably beyond the call of duty. + +You can then add something like this to your F<Makefile.PL>. It +overrides the L<ExtUtils::MakeMaker> C<test_via_harness()> method to run the tests +against several different versions of Perl. + + # If PERL_TEST_ALL is set, run "make test" against + # other perls as well as the current perl. + { + package MY; + + sub test_via_harness { + my($self, $orig_perl, $tests) = @_; + + # names of your other perl binaries. + my @other_perls = qw(perl5.004_05 perl5.005_03 perl5.7.2); + + my @perls = ($orig_perl); + push @perls, @other_perls if $ENV{PERL_TEST_ALL}; + + my $out; + foreach my $perl (@perls) { + $out .= $self->SUPER::test_via_harness($perl, $tests); + } + + return $out; + } + } + +and re-run your F<Makefile.PL> with the C<PERL_TEST_ALL> environment +variable set + + PERL_TEST_ALL=1 perl Makefile.PL + +now C<make test> will run against each of your other perls. + + +=head2 If I'm testing Foo::Bar, where do I put tests for Foo::Bar::Baz? + +=head2 How do I know when my tests are good enough? + +A: Use tools for measuring the code coverage of your tests, e.g. how many of +your source code lines/subs/expressions/paths are executed (aka covered) by +the test suite. The more, the better, of course, although you may not +be able achieve 100%. If your testsuite covers under 100%, then +the rest of your code is, basically, untested. Which means it may work in +surprising ways (e.g. doesn't do things like they are intended or +documented), have bugs (e.g. return wrong results) or it may not work at +all. + +=head2 How do I measure the coverage of my test suite? + +L<Devel::Cover> + +=head2 How do I get tests to run in a certain order? + +Tests run in alphabetical order, so simply name your test files in the order +you want them to run. Numbering your test files works, too. + + t/00_compile.t + t/01_config.t + t/zz_teardown.t + +0 runs first, z runs last. + +To achieve a specific order, try L<Test::Manifest>. + +Typically you do B<not> want your tests to require being run in a +certain order, but it can be useful to do a compile check first or to +run the tests on a very basic module before everything else. This +gives you early information if a basic module fails which will bring +everything else down. + +Another use is if you have a suite wide setup/teardown, such as +creating and delete a large test database, which may be too +expensive to do for every test. + +We recommend B<against> numbering every test file. For most files +this ordering will be arbitrary and the leading number obscures the +real name of the file. See L<What should I name my test files?> for +more information. + + +=head2 What should I name my tests? + +=head2 What should I name my test files? + +A test filename serves three purposes: + +Most importantly, it serves to identify what is being tested. Each +test file should test a clear piece of functionality. This could be +at single class, a single method, even a single bug. + +The order in which tests are run is usually dictated by the filename. +See L<How do I get tests to run in a certain order?> for details. + +Finally, the grouping of tests into common bits of functionality can +be achieved by directory and filenames. For example, all the tests +for L<Test::Builder> are in the F<t/Builder/> directory. + +As an example, F<t/Builder/reset.t> contains the tests for +C<< Test::Builder->reset >>. F<t/00compile.t> checks that everything +compiles, and it will run first. F<t/dont_overwrite_die_handler.t> +checks that we don't overwrite the C<< $SIG{__DIE__} >> handler. + + +=head2 How do I deal with tests that sometimes pass and sometimes fail? + +=head2 How do I test with a database/network/server that the user may or may not have? + +=head2 What's a good way to test lists? + +C<is_deeply()> from L<Test::More> as well as L<Test::Deep>. + +=head2 Is there such a thing as untestable code? + +There's always compile/export checks. + +Code must be written with testability in mind. Separation of form and +functionality. + +=head2 What do I do when I can't make the code do the same thing twice? + +Force it to do the same thing twice. + +Even a random number generator can be tested. + +=head2 How do I test a GUI? + +=head2 How do I test an image generator? + +=head2 How do I test that my code handles failures gracefully? + +=head2 How do I check the right warnings are issued? + +L<Test::Warn> + +=head2 How do I test code that prints? + +L<Test::Output> + +=head2 I want to test that my code dies when I do X + +L<Test::Exception> + +=head2 I want to print out more diagnostic info on failure. + +C<ok(...) || diag "...";> + +=head2 How can I simulate failures to make sure that my code does the Right Thing in the face of them? + + +=head2 Why use an ok() function? + +On Tue, Aug 28, 2001 at 02:12:46PM +0100, Robin Houston wrote: +> Michael Schwern wrote: +> > Ah HA! I've been wondering why nobody ever thinks to write a simple +> > ok() function for their tests! perlhack has bad testing advice. +> +> Could you explain the advantage of having a "simple ok() function"? + +Because writing: + + print "not " unless some thing worked; + print "ok $test\n"; $test++; + +gets rapidly annoying. This is why we made up subroutines in the +first place. It also looks like hell and obscures the real purpose. + +Besides, that will cause problems on VMS. + + +> As somebody who has spent many painful hours debugging test failures, +> I'm intimately familiar with the _disadvantages_. When you run the +> test, you know that "test 113 failed". That's all you know, in general. + +Second advantage is you can easily upgrade the C<ok()> function to fix +this, either by slapping this line in: + + printf "# Failed test at line %d\n", (caller)[2]; + +or simply junking the whole thing and switching to L<Test::Simple> or +L<Test::More>, which does all sorts of nice diagnostics-on-failure for +you. Its C<ok()> function is backwards compatible with the above. + +There's some issues with using L<Test::Simple> to test really basic Perl +functionality, you have to choose on a per test basis. Since +L<Test::Simple> doesn't use C<pack()> it's safe for F<t/op/pack.t> to use +L<Test::Simple>. I just didn't want to make the perlhack patching +example too complicated. + + +=head2 Dummy Mode + +> One compromise would be to use a test-generating script, which allows +> the tests to be structured simply and _generates_ the actual test +> code. One could then grep the generated test script to locate the +> failing code. + +This is a very interesting, and very common, response to the problem. +I'm going to make some observations about reactions to testing, +they're not specific to you. + +If you've ever read the Bastard Operator From Hell series, you'll +recall the Dummy Mode. + + The words "power surging" and "drivers" have got her. People hear + words like that and go into Dummy Mode and do ANYTHING you say. I + could tell her to run naked across campus with a powercord rammed + up her backside and she'd probably do it... Hmmm... + +There seems to be a Dummy Mode WRT testing. An otherwise competent +person goes to write a test and they suddenly forget all basic +programming practice. + + +The reasons for using an C<ok()> function above are the same reasons to +use functions in general, we should all know them. We'd laugh our +heads off at code that repeated as much as your average test does. +These are newbie mistakes. + +And the normal 'can do' flair seems to disappear. I know Robin. I +*know* that in any other situation he would have come up with the +C<caller()> trick in about 15 seconds flat. Instead weird, elaborate, +inelegant hacks are thought up to solve the simplest problems. + + +I guess there are certain programming idioms that are foreign enough +to throw your brain into reverse if you're not ready for them. Like +trying to think in Lisp, for example. Or being presented with OO for +the first time. I guess writing test is one of those. + + +=head2 How do I use Test::More without depending on it? + +Install L<Test::More> into F<t/lib> under your source directory. Then in your tests +say C<use lib 't/lib'>. + +=head2 How do I deal with threads and forking? + + use Test::More qw/enable_forking/; + +or + + use Test::More qw/modern/; + +=head2 Why do I need more than ok? + +Since every test can be reduced to checking if a statement is true, +C<ok()> can test everything. But C<ok()> doesn't tell you why the test +failed. For that you need to tell the test more... which is why +you need L<Test::More>. + + ok $pirate->name eq "Roberts", "person's name"; + + not ok 1 - person's name + # Failed test at pirates.t line 23. + +If the above fails, you don't know what C<< $person->name >> returned. +You have to go in and add a C<diag> call. This is time consuming. If +it's a heisenbug, it might not fail again! If it's a user reporting a +test failure, they might not be bothered to hack the tests to give you +more information. + + is $person->name, "Roberts", "person's name"; + + not ok 1 - person's name + # Failed test at pirates.t line 23. + # got: 'Wesley' + # expected: 'Roberts' + +Using C<is> from L<Test::More> you now know what value you got and +what value you expected. + +The most useful functions in L<Test::More> are C<is()>, C<like()> and C<is_deeply()>. + + +=head2 What's wrong with C<print $test ? "ok" : "not ok">? + +=head2 How do I check for an infinite loop? + +On Mon, Mar 18, 2002 at 03:57:55AM -0500, Mark-Jason Dominus wrote: +> +> Michael The Schwern <schwern@pobox.com> says: +> > Use alarm and skip the test if $Config{d_alarm} is false (see +> > t/op/alarm.t for an example). If you think the infinite loop is due +> > to a programming glitch, as opposed to a cross-platform issue, this +> > will be enough. +> +> Thanks very much! +> + +=head2 How can I check that flock works? + +=head2 How do I use the comparison functions of a testing module without it being a test? + +Any testing function based on L<Test::Builder>, most are, can be quieted so it does +not do any testing. It simply returns true or false. Use the following code... + + use Test::More; # or any testing module + + use Test::Builder; + use File::Spec; + + # Get the internal Test::Builder object + my $tb = Test::Builder->new; + + $tb->plan("no_plan"); + + # Keep Test::Builder from displaying anything + $tb->no_diag(1); + $tb->no_ending(1); + $tb->no_header(1); + $tb->output( File::Spec->devnull ); + + # Now you can use the testing function. + print is_deeply( "foo", "bar" ) ? "Yes" : "No"; + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 12fcea6c2e..04aca81e86 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -1,97 +1,491 @@ package Test::More; -use 5.006; +use 5.008001; use strict; use warnings; -#---- perlcritic exemptions. ----# +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Stream 1.301001 '-internal'; +use Test::Stream::Util qw/protect try spoof/; +use Test::Stream::Toolset; + +use Test::Stream::Carp qw/croak carp/; +use Scalar::Util qw/blessed/; + +use Test::More::Tools; +use Test::More::DeepCheck::Strict; + +use Test::Builder; + +use Test::Stream::Exporter qw/ + default_export default_exports import export_to export_to_level +/; -# We use a lot of subroutine prototypes -## no critic (Subroutines::ProhibitSubroutinePrototypes) +our $TODO; +default_export '$TODO' => \$TODO; +default_exports qw{ + context + plan done_testing -# Can't use Carp because it might cause C<use_ok()> 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"; + ok + is isnt + like unlike + cmp_ok + is_deeply + eq_array eq_hash eq_set + can_ok isa_ok new_ok + pass fail + require_ok use_ok + subtest + + explain + + diag note + + skip todo_skip + BAIL_OUT +}; +Test::Stream::Exporter->cleanup; + +{ + no warnings 'once'; + $Test::Builder::Level ||= 1; } -our $VERSION = '1.001009'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +sub builder { Test::Builder->new } + +sub before_import { + my $class = shift; + my ($importer, $list) = @_; + + my $meta = init_tester($importer); + + my $context = context(1); + my $other = []; + my $idx = 0; + + while ($idx <= $#{$list}) { + my $item = $list->[$idx++]; + next unless $item; + + if (defined $item and $item eq 'no_diag') { + Test::Stream->shared->set_no_diag(1); + } + elsif ($item eq 'tests') { + $context->plan($list->[$idx++]); + } + elsif ($item eq 'skip_all') { + $context->plan(0, 'SKIP', $list->[$idx++]); + } + elsif ($item eq 'no_plan') { + $context->plan(0, 'NO PLAN'); + } + elsif ($item eq 'import') { + push @$other => @{$list->[$idx++]}; + } + else { + carp("Unknown option: $item"); + } + } + + @$list = @$other; + + return; +} + +sub ok ($;$) { + my $ctx = context(); + $ctx->ok(@_); + return $_[0] ? 1 : 0; +} + +sub plan { + return unless @_; + my ($directive, $arg) = @_; + my $ctx = context(); + + if ($directive eq 'tests') { + $ctx->plan($arg); + } + else { + $ctx->plan(0, $directive, $arg); + } +} + +sub done_testing { + my ($num) = @_; + my $ctx = context(); + $ctx->done_testing($num); +} + +sub is($$;$) { + my ($got, $want, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = tmt->is_eq($got, $want); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub isnt ($$;$) { + my ($got, $forbid, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = tmt->isnt_eq($got, $forbid); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +{ + no warnings 'once'; + *isn't = \&isnt; + # ' to unconfuse syntax higlighters +} + +sub like ($$;$) { + my ($got, $check, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = tmt->regex_check($got, $check, '=~'); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub unlike ($$;$) { + my ($got, $forbid, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = tmt->regex_check($got, $forbid, '!~'); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub cmp_ok($$$;$) { + my ($got, $type, $expect, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = tmt->cmp_check($got, $type, $expect); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub can_ok($@) { + my ($thing, @methods) = @_; + my $ctx = context(); + + my $class = ref $thing || $thing || ''; + my ($ok, @diag); + + if (!@methods) { + ($ok, @diag) = (0, " can_ok() called with no methods"); + } + elsif (!$class) { + ($ok, @diag) = (0, " can_ok() called with empty class or reference"); + } + else { + ($ok, @diag) = tmt->can_check($thing, $class, @methods); + } + + my $name = (@methods == 1 && defined $methods[0]) + ? "$class\->can('$methods[0]')" + : "$class\->can(...)"; + + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub isa_ok ($$;$) { + my ($thing, $class, $thing_name) = @_; + my $ctx = context(); + $thing_name = "'$thing_name'" if $thing_name; + my ($ok, @diag) = tmt->isa_check($thing, $class, \$thing_name); + my $name = "$thing_name isa '$class'"; + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +sub new_ok { + croak "new_ok() must be given at least a class" unless @_; + my ($class, $args, $object_name) = @_; + my $ctx = context(); + my ($obj, $name, $ok, @diag) = tmt->new_check($class, $args, $object_name); + $ctx->ok($ok, $name, \@diag); + return $obj; +} + +sub pass (;$) { + my $ctx = context(); + return $ctx->ok(1, @_); +} + +sub fail (;$) { + my $ctx = context(); + return $ctx->ok(0, @_); +} + +sub subtest { + my $ctx = context(); + return tmt->subtest(@_); +} + +sub explain { + my $ctx = context(); + tmt->explain(@_); +} + +sub diag { + my $ctx = context(); + $ctx->diag($_) for @_; +} + +sub note { + my $ctx = context(); + $ctx->note($_) for @_; +} + +sub skip { + my( $why, $how_many ) = @_; + my $ctx = context(); + + _skip($why, $how_many, 'skip', 1); + + no warnings 'exiting'; + last SKIP; +} + +sub _skip { + my( $why, $how_many, $func, $bool ) = @_; + my $ctx = context(); + + my $plan = $ctx->stream->plan; + + # If there is no plan we do not need to worry about counts + my $need_count = $plan ? !($plan->directive && $plan->directive eq 'NO PLAN') : 0; + + if ($need_count && !defined $how_many) { + $ctx->alert("$func() needs to know \$how_many tests are in the block"); + $how_many = 1; + } + + $ctx->alert("$func() was passed a non-numeric number of tests. Did you get the arguments backwards?") + if defined $how_many and $how_many =~ /\D/; + + return unless $how_many || !$bool; + + $ctx->set_skip($why); + $how_many ||= 1; + for( 1 .. $how_many ) { + $ctx->ok($bool, ''); + } +} + +sub todo_skip { + my($why, $how_many) = @_; + + my $ctx = context(); + $ctx->set_in_todo(1); + $ctx->set_todo($why); + _skip($why, $how_many, 'todo_skip', 0); + + no warnings 'exiting'; + last TODO; +} + +sub BAIL_OUT { + my ($reason) = @_; + my $ctx = context(); + $ctx->bail($reason); +} + +sub is_deeply { + my ($got, $want, $name) = @_; + + my $ctx = context(); + + 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 + + $ctx->alert(sprintf $msg, scalar @_); + + $ctx->ok(0, undef, ['incorrect number of args']); + return 0; + } + + my ($ok, @diag) = Test::More::DeepCheck::Strict->check($got, $want); + $ctx->ok($ok, $name, \@diag); + return $ok; +} -use Test::Builder::Module 0.99; -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 -); +sub eq_array { + my ($got, $want, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = Test::More::DeepCheck::Strict->check_array($got, $want); + return $ok; +} + +sub eq_hash { + my ($got, $want, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = Test::More::DeepCheck::Strict->check_hash($got, $want); + return $ok; +} + +sub eq_set { + my ($got, $want, $name) = @_; + my $ctx = context(); + my ($ok, @diag) = Test::More::DeepCheck::Strict->check_set($got, $want); + return $ok; +} + +sub require_ok($;$) { + my($module) = shift; + my $ctx = context(); + + # 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 ($ret, $err); + { + local $SIG{__DIE__}; + ($ret, $err) = spoof [caller] => "require $module"; + } + + my @diag; + unless ($ret) { + chomp $err; + push @diag => <<" DIAG"; + Tried to require '$module'. + Error: $err + DIAG + } + + $ctx->ok( $ret, "require $module;", \@diag ); + return $ret ? 1 : 0; +} + +sub _is_module_name { + my $module = shift; + + # Module names start with a letter. + # End with an alphanumeric. + # The rest is an alphanumeric or :: + $module =~ s/\b::\b//g; + + return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; +} + +sub use_ok($;@) { + my ($module, @imports) = @_; + @imports = () unless @imports; + my $ctx = context(); + + my($pack, $filename, $line) = caller; + $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line + + my ($ret, $err, $newdie, @diag); + { + local $SIG{__DIE__}; + + 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. + ($ret, $err) = spoof [$pack, $filename, $line] => "use $module $imports[0]"; + } + else { + ($ret, $err) = spoof [$pack, $filename, $line] => "use $module \@args", @imports; + } + + $newdie = $SIG{__DIE__}; + } + + $SIG{__DIE__} = $newdie if defined $newdie; + + unless ($ret) { + chomp $err; + push @diag => <<" DIAG"; + Tried to use '$module'. + Error: $err + DIAG + } + + $ctx->ok($ret, "use $module;", \@diag); + + return $ret ? 1 : 0; +} + +1; + +__END__ =head1 NAME -Test::More - yet another framework for writing test scripts +Test::More - The defacto standard in unit testing tools. =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' ); + # Enabled forking, and removes expensive legacy support; + use Test::Stream; - # Various ways to say "ok" - ok($got eq $expected, $test_name); + # Load after Test::Stream to get the benefits of removed legacy + use Test::More; - is ($got, $expected, $test_name); - isnt($got, $expected, $test_name); + use ok 'Some::Module'; - # Rather than print STDERR "# here's what went wrong\n" - diag("here's what went wrong"); + can_ok($module, @methods); + isa_ok($object, $class); - like ($got, qr/expected/, $test_name); - unlike($got, qr/expected/, $test_name); + pass($test_name); + fail($test_name); - cmp_ok($got, '==', $expected, $test_name); + ok($got eq $expected, $test_name); - is_deeply($got_complex_structure, $expected_complex_structure, $test_name); + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); - SKIP: { - skip $why, $how_many unless $have_some_feature; + like ($got, qr/expected/, $test_name); + unlike($got, qr/expected/, $test_name); - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; + cmp_ok($got, '==', $expected, $test_name); - TODO: { - local $TODO = $why; + is_deeply( + $got_complex_structure, + $expected_complex_structure, + $test_name + ); - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); - can_ok($module, @methods); - isa_ok($object, $class); + SKIP: { + skip $why, $how_many unless $have_some_feature; - pass($test_name); - fail($test_name); + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; - BAIL_OUT($why); + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + sub my_compare { + my ($got, $want, $name) = @_; + my $ctx = context(); + my $ok = $got eq $want; + $ctx->ok($ok, $name); + ... + return $ok; + }; - # UNIMPLEMENTED!!! - my @status = Test::More::status; + # If this fails it will report this line instead of the line in my_compare. + my_compare('a', 'b'); + done_testing; =head1 DESCRIPTION @@ -105,7 +499,6 @@ facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C<ok()> 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 @@ -160,40 +553,6 @@ or for deciding between running the tests at all: 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; - while( $idx <= $#{$list} ) { - my $item = $list->[$idx]; - - if( defined $item and $item eq 'no_diag' ) { - $class->builder->no_diag(1); - } - else { - push @other, $item; - } - - $idx++; - } - - @$list = @other; - - return; -} - =over 4 =item B<done_testing> @@ -213,12 +572,111 @@ This is safer than and replaces the "no_plan" plan. =back -=cut +=head2 Test::Stream -sub done_testing { - my $tb = Test::More->builder; - $tb->done_testing(@_); -} +When you use Test::Stream, it enables support for forking in your tests. If it +is loaded before Test::More then it will prevent the insertion of some legacy +support shims, saving you memory and improving performance. + + use Test::Stream; + use Test::More; + +=head2 TAP Encoding + +You can now control the encoding of your TAP output using Test::Stream. + + use Test::Stream; # imports tap_encoding + use Test::More; + + tap_encoding 'utf8'; + +You can also just set 'utf8' it at import time + + use Test::Stream 'utf8'; + +or something other than utf8 + + use Test::Stream encoding => 'latin1'; + +=over 4 + +=item tap_encoding 'utf8'; + +=item tap_encoding 'YOUR_ENCODING'; + +=item tap_encoding 'xxx' => sub { ... }; + +The C<tap_encoding($encoding)> function will ensure that any B<FUTURE> TAP +output produced by I<This Package> will be output in the specified encoding. + +You may also provide a codeblock in which case the scope of the encoding change +will only apply to that codeblock. + +B<Note>: This is effective only for the current package. Other packages can/may +select other encodings for their TAP output. For packages where none is +specified, the original STDOUT and STDERR settings are used, the results are +unpredictable. + +B<Note>: The encoding of the TAP, it is necessary to set to match the +locale of the encoding of the terminal. + +However, in tests code that are performed in a variety of environments, +it can not be assumed in advance the encoding of the locale of the terminal, +it is recommended how to set the encoding to your environment using the +C<Encode::Locale> module. + +The following is an example of code. + + use utf8; + use Test::Stream; + use Test::More; + use Encode::Locale; + + tap_encoding('console_out'); + +B<Note>: Filenames are a touchy subject: + +Different OS's and filesystems handle filenames differently. When you do not +specify an encoding, the filename will be unmodified, you get whatever perl +thinks it is. If you do specify an encoding, the filename will be assumed to be +in that encoding, and an attempt will be made to unscramble it. If the +unscrambling fails the original name will be used. + +This filename unscrambling is necessary for example on linux systems when you +use utf8 encoding and a utf8 filename. Perl will read the bytes of the name, +and treat them as bytes. if you then try to print the name to a utf8 handle it +will treat each byte as a different character. Test::More attempts to fix this +scrambling for you. + +=back + +=head2 Helpers + +Sometimes you want to write functions for things you do frequently that include +calling ok() or other test functions. Doing this can make it hard to debug +problems as failures will be reported in your sub, and not at the place where +you called your sub. Now there is a solution to this, the +L<Test::Stream::Context> object!. + +Test::More exports the C<context()> function which will return a context object +for your use. The idea is that you generate a context object at the lowest +level (the function you call from your test file). Deeper functions that need +context will get the object you already generated, at least until the object +falls out of scope or is undefined. + + sub my_compare { + my ($got, $want, $name) = @_; + my $ctx = context(); + + # is() will find the context object above, instead of generating a new + # one. That way a failure will be reported to the correct line + is($got, $want); + + # This time it will generate a new context object. That means a failure + # will report to this line. + $ctx = undef; + is($got, $want); + }; =head2 Test names @@ -285,15 +743,6 @@ Should an C<ok()> fail, it will produce some diagnostics: This is the same as L<Test::Simple>'s C<ok()> routine. -=cut - -sub ok ($;$) { - my( $test, $name ) = @_; - my $tb = Test::More->builder; - - return $tb->ok( $test, $name ); -} - =item B<is> =item B<isnt> @@ -368,23 +817,6 @@ different from some other value: For those grammatical pedants out there, there's an C<isn't()> function which is an alias of C<isnt()>. -=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> like( $got, qr/expected/, $test_name ); @@ -413,14 +845,6 @@ Regex options may be placed on the end (C<'/expected/i'>). Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better diagnostics on failure. -=cut - -sub like ($$;$) { - my $tb = Test::More->builder; - - return $tb->like(@_); -} - =item B<unlike> unlike( $got, qr/expected/, $test_name ); @@ -428,14 +852,6 @@ sub like ($$;$) { Works exactly as C<like()>, only it checks if $got B<does not> match the given pattern. -=cut - -sub unlike ($$;$) { - my $tb = Test::More->builder; - - return $tb->unlike(@_); -} - =item B<cmp_ok> cmp_ok( $got, $op, $expected, $test_name ); @@ -468,20 +884,11 @@ C<is()>'s use of C<eq> will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); -It's especially useful when comparing greater-than or smaller-than +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> can_ok($module, @methods); @@ -494,9 +901,9 @@ Checks to make sure the $module or $object can do these @methods is almost exactly like saying: - ok( Foo->can('this') && - Foo->can('that') && - Foo->can('whatever') + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') ); only without all the typing and with a better interface. Handy for @@ -509,40 +916,6 @@ as one test. If you desire otherwise, use: 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> isa_ok($object, $class, $object_name); @@ -575,88 +948,6 @@ 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 <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/; -WHOA! I tried to call ->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<new_ok> my $obj = new_ok( $class ); @@ -676,31 +967,6 @@ If @args is not given, an empty list will be used. This function only works on C<new()> and it assumes C<new()> 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> subtest $name => \&code; @@ -712,7 +978,7 @@ 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 { @@ -762,15 +1028,6 @@ subtests are equivalent: done_testing(); }; -=cut - -sub subtest { - my ($name, $subtests) = @_; - - my $tb = Test::More->builder; - return $tb->subtest(@_); -} - =item B<pass> =item B<fail> @@ -786,23 +1043,8 @@ C<ok(1)> and C<ok(0)>. 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 @@ -810,12 +1052,44 @@ 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<use_ok> and C<require_ok>. +For such purposes we have C<use ok 'module'>. C<use_ok> is still around, but is +considered discouraged in favor of C<use ok 'module'>. C<require_ok> is also +discouraged because it tries to guess if you gave it a file name or module +name. C<require_ok>'s guessing mechanism is broken, but fixing it can break +things. =over 4 +=item B<use ok 'module'> + +=item B<use ok 'module', @args> + + use ok 'Some::Module'; + use ok 'Another::Module', qw/import_a import_b/; + +This will load the specified module and pass through any extra arguments to +that module. This will also produce a test result. + +B<Note - Do not do this:> + + my $class = 'My::Module'; + use ok $class; + +The value 'My::Module' is not assigned to the C<$class> variable until +run-time, but the C<use ok $class> statement is run at compile time. The result +of this is that we try to load 'undef' as a module. This will generate an +exception: C<'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable?> + +If you must do something like this, here is a more-correct way: + + my $class; + BEGIN { $class = 'My::Module' } + use ok $class; + =item B<require_ok> +B<***DISCOURAGED***> - Broken guessing + require_ok($module); require_ok($file); @@ -839,53 +1113,10 @@ No exception will be thrown if the load fails. 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 = <<REQUIRE; -package $pack; -require $module; -1; -REQUIRE - - my( $eval_result, $eval_error ) = _eval($code); - my $ok = $tb->ok( $eval_result, "require $module;" ); - - unless($ok) { - chomp $eval_error; - $tb->diag(<<DIAGNOSTIC); - Tried to require '$module'. - Error: $eval_error -DIAGNOSTIC - - } - - return $ok; -} - -sub _is_module_name { - my $module = shift; - - # Module names start with a letter. - # End with an alphanumeric. - # The rest is an alphanumeric or :: - $module =~ s/\b::\b//g; - - return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; -} - - =item B<use_ok> +B<***DISCOURAGED***> See C<use ok 'module'> + BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } @@ -933,77 +1164,8 @@ import anything, use C<require_ok>. BEGIN { require_ok "Foo" } -=cut - -sub use_ok ($;@) { - my( $module, @imports ) = @_; - @imports = () unless @imports; - my $tb = Test::More->builder; - - my( $pack, $filename, $line ) = caller; - $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 = <<USE; -package $pack; - -#line $line $filename -use $module $imports[0]; -1; -USE - } - else { - $code = <<USE; -package $pack; - -#line $line $filename -use $module \@{\$args[0]}; -1; -USE - } - - my( $eval_result, $eval_error ) = _eval( $code, \@imports ); - my $ok = $tb->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(<<DIAGNOSTIC); - Tried to use '$module'. - Error: $eval_error -DIAGNOSTIC - - } - - return $ok; -} - -sub _eval { - my( $code, @args ) = @_; - - # Work around oddities surrounding resetting of $@ by immediately - # storing it. - my( $sigdie, $eval_result, $eval_error ); - { - local( $@, $!, $SIG{__DIE__} ); # isolate eval - $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval) - $eval_error = $@; - $sigdie = $SIG{__DIE__} || undef; - } - # make sure that $code got a chance to set $SIG{__DIE__} - $SIG{__DIE__} = $sigdie if defined $sigdie; - - return( $eval_result, $eval_error ); -} - - =back - =head2 Complex data structures Not everything is a simple eq check or regex. There are times you @@ -1034,112 +1196,6 @@ improve in the future. L<Test::Differences> and L<Test::Deep> provide more in-depth functionality along these lines. -=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)) { - return $type if UNIVERSAL::isa( $thing, $type ); - } - - return ''; -} =back @@ -1194,16 +1250,6 @@ 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<explain> my @dump = explain @diagnostic_message; @@ -1220,12 +1266,6 @@ or note explain \%args; Some::Class->method(%args); -=cut - -sub explain { - return Test::More->builder->explain(@_); -} - =back @@ -1233,7 +1273,7 @@ sub explain { 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<fork()> on MacOS), some resource isn't available (like a +(such as C<fork()> 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). @@ -1286,34 +1326,6 @@ 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; - - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. - _carp "skip() needs to know \$how_many tests are in the block" - unless $tb->has_plan eq 'no_plan'; - $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: BLOCK> TODO: { @@ -1370,26 +1382,6 @@ The syntax and behavior is similar to a C<SKIP: BLOCK> except the tests will be marked as failing but todo. L<Test::Harness> 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? @@ -1425,18 +1417,8 @@ The test will exit with 255. For even better control look at L<Test::Most>. -=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 @@ -1449,7 +1431,7 @@ These functions are usually used inside an C<ok()>. ok( eq_array(\@got, \@expected) ); -C<is_deeply()> can do that better and with diagnostics. +C<is_deeply()> can do that better and with diagnostics. is_deeply( \@got, \@expected ); @@ -1464,146 +1446,6 @@ They may be deprecated in future versions. 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<eq_hash> my $is_eq = eq_hash(\%got, \%expected); @@ -1611,40 +1453,6 @@ WHOA 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<eq_set> @@ -1670,58 +1478,17 @@ level. The following is an example of a comparison which might not work: L<Test::Deep> 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<Test::Builder> which provides a single, +Test::More is built on top of L<Test::Stream> which provides a single, unified backend for any test library to use. This means two test -libraries which both use <Test::Builder> B<can> be used together in the +libraries which both use <Test::Stream> B<can> 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<Test::Builder> object like so: - -=over 4 - -=item B<builder> - - my $test_builder = Test::More->builder; - -Returns the L<Test::Builder> object underlying Test::More for you to play -with. - - -=back - - =head1 EXIT CODES If all your tests passed, L<Test::Builder> will exit with zero (which is @@ -1750,31 +1517,53 @@ 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<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. +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<done_testing()> 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 event stream + +=item forking support + +=item tap encoding + +Test::Builder and Test::More version 1.301001 introduce these major +modernizations. + =item subtests -Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. +Subtests were released in Test::More 0.94, which came with Perl 5.12.0. +Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl +with that fix was Perl 5.14.0 with 0.98. =item C<done_testing()> -This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. +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<cmp_ok()> -Although C<cmp_ok()> 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. +Although C<cmp_ok()> 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<new_ok()> C<note()> and C<explain()> -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. +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<Module::CoreList>: +There is a full version history in the Changes file, and the Test::More +versions included as core can be found using L<Module::CoreList>: $ corelist -a Test::More @@ -1786,22 +1575,33 @@ There is a full version history in the Changes file, and the Test::More versions =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<Test::Builder> (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. +might get a "Wide character in print" warning. +Using C<< binmode STDOUT, ":utf8" >> will not fix it. + +Use the C<tap_encoding> function to configure the TAP stream encoding. + + use utf8; + use Test::Stream; # imports tap_encoding + use Test::More; + tap_encoding 'utf8'; + +L<Test::Builder> (which powers Test::More) duplicates STDOUT and STDERR. +So any changes to them, including changing their output disciplines, +will not be seen by Test::More. + +B<Note>:deprecated ways to use utf8 or other non-ASCII characters. -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. +In the past it was necessary to alter the filehandle encoding prior to loading +Test::More. This is no longer necessary thanks to C<tap_encoding()>. + # *** DEPRECATED WAY *** use open ':std', ':encoding(utf8)'; use Test::More; A more direct work around is to change the filehandles used by L<Test::Builder>. + # *** EVEN MORE DEPRECATED WAY *** my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; @@ -1825,6 +1625,11 @@ complex data structures. =item Threads +B<NOTE:> The underlying mechanism to support threads has changed as of version +1.301001. Instead of sharing several variables and locking them, threads now +use the same mechanism as forking support. The new system writes events to temp +files which are culled by the main process. + Test::More will only be aware of threads if C<use threads> has been done I<before> Test::More is loaded. This is ok: @@ -1907,14 +1712,14 @@ L<Bundle::Test> installs a whole bunch of useful test modules. L<Test::Most> Most commonly needed test functions and features. -=head1 AUTHORS +=encoding utf8 -Michael G Schwern E<lt>schwern@pobox.comE<gt> 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 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. -=head1 MAINTAINERS +=head1 MAINTAINER =over 4 @@ -1922,20 +1727,57 @@ the perl-qa gang. =back +=head1 AUTHORS -=head1 BUGS +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). -See F<http://rt.cpan.org> to report and view bugs. +=over 4 +=item Chad Granum E<lt>exodist@cpan.orgE<gt> -=head1 SOURCE +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> -The source code repository for Test::More can be found at -F<http://github.com/Test-More/test-more/>. +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> +=item 唐鳳 + +=back =head1 COPYRIGHT +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. This program is free software; you can redistribute it and/or @@ -1943,6 +1785,29 @@ modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> -=cut +=item Test::use::ok -1; +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck.pm new file mode 100644 index 0000000000..4ec03fa2bf --- /dev/null +++ b/cpan/Test-Simple/lib/Test/More/DeepCheck.pm @@ -0,0 +1,223 @@ +package Test::More::DeepCheck; +use strict; +use warnings; + +use Test::Stream::ArrayBase( + accessors => [qw/seen/], +); + +sub init { + $_[0]->[SEEN] ||= [{}]; +} + +my %PAIRS = ( '{' => '}', '[' => ']' ); +my $DNE = bless [], 'Does::Not::Exist'; + +sub is_dne { ref $_[-1] eq ref $DNE } +sub dne { $DNE }; + +sub preface { "" }; + +sub format_stack { + my $self = shift; + my $start = $self->STACK_START; + my $end = @$self - 1; + + my @Stack = @{$self}[$start .. $end]; + + my @parts1 = (' $got'); + my @parts2 = ('$expected'); + + my $did_arrow = 0; + for my $entry (@Stack) { + next unless $entry; + my $type = $entry->{type} || ''; + my $idx = $entry->{idx}; + my $key = $entry->{key}; + my $wrap = $entry->{wrap}; + + if ($type eq 'HASH') { + unless ($did_arrow) { + push @parts1 => '->'; + push @parts2 => '->'; + $did_arrow++; + } + push @parts1 => "{$idx}"; + push @parts2 => "{$idx}"; + } + elsif ($type eq 'OBJECT') { + push @parts1 => '->'; + push @parts2 => '->'; + push @parts1 => "$idx()"; + push @parts2 => "{$idx}"; + $did_arrow = 0; + } + elsif ($type eq 'ARRAY') { + unless ($did_arrow) { + push @parts1 => '->'; + push @parts2 => '->'; + $did_arrow++; + } + push @parts1 => "[$idx]"; + push @parts2 => "[$idx]"; + } + elsif ($type eq 'REF') { + unshift @parts1 => '${'; + unshift @parts2 => '${'; + push @parts1 => '}'; + push @parts2 => '}'; + } + + if ($wrap) { + my $pair = $PAIRS{$wrap}; + unshift @parts1 => $wrap; + unshift @parts2 => $wrap; + push @parts1 => $pair; + push @parts2 => $pair; + } + } + + my $error = $Stack[-1]->{error}; + chomp($error) if $error; + + my @vals = @{$Stack[-1]{vals}}[0, 1]; + my @vars = ( + join('', @parts1), + join('', @parts2), + ); + + my $out = $self->preface; + for my $idx (0 .. $#vals) { + my $val = $vals[$idx]; + $vals[$idx] = + !defined $val ? 'undef' + : is_dne($val) ? "Does not exist" + : ref $val ? "$val" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + $out .= "$error\n" if $error; + + $out =~ s/^/ /msg; + return $out; +} + +1; + +__END__ + +=head1 NAME + +Test::More::DeepCheck - Base class or is_deeply() and mostly_like() +implementations. + +=head1 DESCRIPTION + +This is the base class for deep check functions provided by L<Test::More> and +L<Test::MostlyLike>. This class contains all the debugging and diagnostics +code shared betweent he 2 tools. + +Most of this was refactored from the original C<is_deeply()> implementation. If +you find any bugs or incompatabilities please report them. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm new file mode 100644 index 0000000000..d50e9801ea --- /dev/null +++ b/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm @@ -0,0 +1,328 @@ +package Test::More::DeepCheck::Strict; +use strict; +use warnings; + +use Scalar::Util qw/reftype/; +use Test::More::Tools; +use Test::Stream::Carp qw/cluck confess/; +use Test::Stream::Util qw/try unoverload_str is_regex/; + +use Test::Stream::ArrayBase( + accessors => [qw/stack_start/], + base => 'Test::More::DeepCheck', +); + +sub preface { "Structures begin differing at:\n" } + +sub check { + my $class = shift; + my ($got, $expect) = @_; + + unoverload_str(\$got, \$expect); + my $self = $class->new(); + + # neither is a reference + return tmt->is_eq($got, $expect) + if !ref $got and !ref $expect; + + # one's a reference, one isn't + if (!ref $got xor !ref $expect) { + push @$self => {vals => [$got, $expect], line => __LINE__}; + return (0, $self->format_stack); + } + + push @$self => {vals => [$got, $expect], line => __LINE__}; + my $ok = $self->_deep_check($got, $expect); + return ($ok, $ok ? () : $self->format_stack); +} + +sub check_array { + my $class = shift; + my ($got, $expect) = @_; + my $self = $class->new(); + push @$self => {vals => [$got, $expect], line => __LINE__}; + my $ok = $self->_deep_check($got, $expect); + return ($ok, $ok ? () : $self->format_stack); +} + +sub check_hash { + my $class = shift; + my ($got, $expect) = @_; + my $self = $class->new(); + push @$self => {vals => [$got, $expect], line => __LINE__}; + my $ok = $self->_deep_check($got, $expect); + return ($ok, $ok ? () : $self->format_stack); +} + +sub check_set { + my $class = shift; + my ($got, $expect) = @_; + + return 0 unless @$got == @$expect; + + 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 $class->check_array( + [ grep( ref, @$got ), sort( grep( !ref, @$got ) ) ], + [ grep( ref, @$expect ), sort( grep( !ref, @$expect ) ) ], + ); +} + +sub _deep_check { + my $self = shift; + confess "XXX" unless ref $self; + my($e1, $e2) = @_; + + 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); + + return 0 if defined $e1 xor defined $e2; + return 1 if !defined $e1 and !defined $e2; # Shortcut if they're both undefined. + return 0 if $self->is_dne($e1) xor $self->is_dne($e2); + return 1 if $same_ref and ($e1 eq $e2); + + if ($not_ref) { + push @$self => {type => '', vals => [$e1, $e2], line => __LINE__}; + return 0; + } + + # This avoids picking up the same referenced used twice (such as + # [\$a, \$a]) to be considered circular. + my $seen = {%{$self->[SEEN]->[-1]}}; + push @{$self->[SEEN]} => $seen; + my $ok = $self->_inner_check($seen, $e1, $e2); + pop @{$self->[SEEN]}; + return $ok; +} + +sub _inner_check { + my $self = shift; + my ($seen, $e1, $e2) = @_; + + return $seen->{$e1} if $seen->{$e1} && $seen->{$e1} eq $e2; + $seen->{$e1} = "$e2"; + + my $type1 = reftype($e1) || ''; + my $type2 = reftype($e2) || ''; + my $diff = $type1 ne $type2; + + if ($diff) { + push @$self => {type => 'DIFFERENT', vals => [$e1, $e2], line => __LINE__}; + return 0; + } + + return $self->_check_array($e1, $e2) if $type1 eq 'ARRAY'; + return $self->_check_hash($e1, $e2) if $type1 eq 'HASH'; + + if ($type1 eq 'REF' || $type1 eq 'SCALAR' && !(defined(is_regex($e1)) && defined(is_regex($e2)))) { + push @$self => {type => 'REF', vals => [$e1, $e2], line => __LINE__}; + my $ok = $self->_deep_check($$e1, $$e2); + pop @$self if $ok; + return $ok; + } + + push @$self => {type => $type1, vals => [$e1, $e2], line => __LINE__}; + return 0; +} + +sub _check_array { + my $self = shift; + my ($a1, $a2) = @_; + + if (grep reftype($_) ne 'ARRAY', $a1, $a2) { + cluck "_check_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 ? $self->dne : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $self->dne : $a2->[$_]; + + next if $self->_check_nonrefs($e1, $e2); + + push @$self => {type => 'ARRAY', idx => $_, vals => [$e1, $e2], line => __LINE__}; + $ok = $self->_deep_check($e1, $e2); + pop @$self if $ok; + + last unless $ok; + } + + return $ok; +} + +sub _check_nonrefs { + my $self = shift; + 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 0; +} + +sub _check_hash { + my $self = shift; + my ($a1, $a2) = @_; + + if (grep {(reftype($_) || '') ne 'HASH' } $a1, $a2) { + cluck "_check_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; + for my $k (sort keys %$bigger) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $self->dne; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $self->dne; + + next if $self->_check_nonrefs($e1, $e2); + + push @$self => {type => 'HASH', idx => $k, vals => [$e1, $e2], line => __LINE__}; + $ok = $self->_deep_check($e1, $e2); + pop @$self if $ok; + + last unless $ok; + } + + return $ok; +} + +1; + +__END__ + +=head1 NAME + +Test::More::DeepCheck::Strict - Where is_deeply() is implemented. + +=head1 DESCRIPTION + +This is the package where the code for C<is_deeply()> from L<Test::More> lives. +This code was refactored into this form, but should remain 100% compatible with +the old implementation. If you find an incompatability please report it. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm new file mode 100644 index 0000000000..ef3fb4505f --- /dev/null +++ b/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm @@ -0,0 +1,330 @@ +package Test::More::DeepCheck::Tolerant; +use strict; +use warnings; + +use Test::More::Tools; +use Scalar::Util qw/reftype blessed/; +use Test::Stream::Util qw/try unoverload_str is_regex/; + +use Test::Stream::ArrayBase( + accessors => [qw/stack_start/], + base => 'Test::More::DeepCheck', +); + +sub preface { "First mismatch:\n" }; + +sub check { + my $class = shift; + my ($got, $expect) = @_; + + unoverload_str(\$got, \$expect); + my $self = $class->new(); + + # neither is a reference + return tmt->is_eq($got, $expect) + if !ref $got and !ref $expect; + + push @$self => {type => '', vals => [$got, $expect], line => __LINE__}; + my $ok = $self->_deep_check($got, $expect); + return ($ok, $ok ? () : $self->format_stack); +} + +#============================ + +sub _reftype { + my ($thing) = @_; + my $type = reftype $thing || return ''; + + $type = uc($type); + + return $type unless $type eq 'SCALAR'; + + $type = 'REGEXP' if $type eq 'REGEX' || defined is_regex($thing); + + return $type; +} + +sub _nonref_check { + my ($self) = shift; + my ($got, $expect) = @_; + + my $numeric = $got !~ m/\D/i && $expect !~ m/\D/i; + return $numeric ? $got == $expect : "$got" eq "$expect"; +} + +sub _deep_check { + my ($self) = shift; + my ($got, $expect) = @_; + + return 1 unless defined($got) || defined($expect); + return 0 if defined($got) xor defined($expect); + + my $seen = $self->[SEEN]->[-1]; + return 1 if $seen->{$got} && $seen->{$got} eq $expect; + $seen->{$got} = "$expect"; + + my $etype = _reftype $expect; + my $gtype = _reftype $got; + + return 0 if ($etype && $etype ne 'REGEXP' && !$gtype) || ($gtype && !$etype); + + return $self->_nonref_check($got, $expect) unless $etype; + + ##### Both are refs at this point #### + return 1 if $gtype && $got == $expect; + + if ($etype eq 'REGEXP') { + return "$got" eq "$expect" if $gtype eq 'REGEXP'; # Identical regexp check + return $got =~ $expect; + } + + my $ok = 0; + $seen = {%$seen}; + push @{$self->[SEEN]} => $seen; + if ($etype eq 'ARRAY') { + $ok = $self->_array_check($got, $expect); + } + elsif ($etype eq 'HASH') { + $ok = $self->_hash_check($got, $expect); + } + pop @{$self->[SEEN]}; + + return $ok; +} + +sub _array_check { + my $self = shift; + my ($got, $expect) = @_; + + return 0 if _reftype($got) ne 'ARRAY'; + + for (my $i = 0; $i < @$expect; $i++) { + push @$self => {type => 'ARRAY', idx => $i, vals => [$got->[$i], $expect->[$i]], line => __LINE__}; + $self->_deep_check($got->[$i], $expect->[$i]) || return 0; + pop @$self; + } + + return 1; +} + +sub _hash_check { + my $self = shift; + my ($got, $expect) = @_; + + my $blessed = blessed($got); + my $hashref = _reftype($got) eq 'HASH'; + my $arrayref = _reftype($got) eq 'ARRAY'; + + for my $key (sort keys %$expect) { + # $wrap $direct $field Leftover from wrap + my ($wrap, $direct, $field) = ($key =~ m/^ ([\[\{]?) (:?) ([^\]]*) [\]\}]?$/x); + + if ($wrap) { + if (!$blessed) { + push @$self => { + type => 'OBJECT', + idx => $field, + wrap => $wrap, + vals => ["(EXCEPTION)", $expect->{$key}], + error => "Cannot call method '$field' on an unblessed reference.\n", + line => __LINE__, + }; + return 0; + } + if ($direct) { + push @$self => { + type => 'OBJECT', + idx => $field, + wrap => $wrap, + vals => ['(EXCEPTION)', $expect->{$key}], + error => "'$key' is invalid, cannot wrap($wrap) a direct-access($direct).\n", + line => __LINE__, + }; + return 0; + } + } + + my ($val, $type); + if ($direct || !$blessed) { + if ($arrayref) { + $type = 'ARRAY'; + if ($field !~ m/^-?\d+$/i) { + push @$self => { + type => 'ARRAY', + idx => $field, + vals => ['(EXCEPTION)', $expect->{$key}], + error => "'$field' is not a valid array index\n", + line => __LINE__, + }; + return 0; + } + + # Try, if they specify -1 in an empty array it may throw an exception + my ($success, $error) = try { $val = $got->[$field] }; + if (!$success) { + push @$self => { + type => 'ARRAY', + idx => $field, + vals => ['(EXCEPTION)', $expect->{$key}], + error => $error, + line => __LINE__, + }; + return 0; + } + } + else { + $type = 'HASH'; + $val = $got->{$field}; + } + } + else { + $type = 'OBJECT'; + my ($success, $error) = try { + if ($wrap) { + if ($wrap eq '[') { + $val = [$got->$field()]; + } + elsif ($wrap eq '{') { + $val = {$got->$field()}; + } + else { + die "'$wrap' is not a valid way to wrap a method call"; + } + } + else { + $val = $got->$field(); + } + }; + if (!$success) { + push @$self => { + type => 'OBJECT', + idx => $field, + wrap => $wrap || undef, + vals => ['(EXCEPTION)', $expect->{$key}], + error => $error, + line => __LINE__, + }; + return 0; + } + } + + push @$self => {type => $type, idx => $field, vals => [$val, $expect->{$key}], line => __LINE__, wrap => $wrap || undef}; + $self->_deep_check($val, $expect->{$key}) || return 0; + pop @$self; + } + + return 1; +} + +1; + +__END__ + +=head1 NAME + +Test::More::DeepCheck::Tolerant - Under the hood implementation of +mostly_like() + +=head1 DESCRIPTION + +This is where L<Test::MostlyLike> is implemented. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/More/Tools.pm b/cpan/Test-Simple/lib/Test/More/Tools.pm new file mode 100644 index 0000000000..7357f35610 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/More/Tools.pm @@ -0,0 +1,540 @@ +package Test::More::Tools; +use strict; +use warnings; + +use Test::Stream::Context; + +use Test::Stream::Exporter; +default_exports qw/tmt/; +Test::Stream::Exporter->cleanup; + +use Test::Stream::Util qw/try protect is_regex unoverload_str unoverload_num/; +use Scalar::Util qw/blessed reftype/; + +sub tmt() { __PACKAGE__ } + +# Bad, these are not comparison operators. Should we include more? +my %CMP_OK_BL = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); +my %NUMERIC_CMPS = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); + +sub cmp_check { + my($class, $got, $type, $expect) = @_; + + my $ctx = context(); + my $name = $ctx->subname; + $name =~ s/^.*:://g; + $name = 'cmp_check' if $name eq '__ANON__'; + $ctx->throw("$type is not a valid comparison operator in $name\()") + if $CMP_OK_BL{$type}; + + my ($p, $file, $line) = $ctx->call; + + my $test = 0; + my ($success, $error) = try { + # This is so that warnings come out at the caller's level + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval qq[ +#line $line "(eval in $name) $file" +\$test = (\$got $type \$expect); +1; + ] || die $@; + }; + + my @diag; + push @diag => <<" END" unless $success; +An error occurred while using $type: +------------------------------------ +$error +------------------------------------ + END + + unless($test) { + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload = $NUMERIC_CMPS{$type} + ? \&unoverload_num + : \&unoverload_str; + + $unoverload->(\$got, \$expect); + + if( $type =~ /^(eq|==)$/ ) { + push @diag => $class->_is_diag( $got, $type, $expect ); + } + elsif( $type =~ /^(ne|!=)$/ ) { + push @diag => $class->_isnt_diag( $got, $type ); + } + else { + push @diag => $class->_cmp_diag( $got, $type, $expect ); + } + } + + return($test, @diag); +} + +sub is_eq { + my($class, $got, $expect) = @_; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + return ($test, $test ? () : $class->_is_diag($got, 'eq', $expect)); + } + + return $class->cmp_check($got, 'eq', $expect); +} + +sub is_num { + my($class, $got, $expect) = @_; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + return ($test, $test ? () : $class->_is_diag($got, '==', $expect)); + } + + return $class->cmp_check($got, '==', $expect); +} + +sub isnt_eq { + my($class, $got, $dont_expect) = @_; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + return ($test, $test ? () : $class->_isnt_diag($got, 'ne')); + } + + return $class->cmp_check($got, 'ne', $dont_expect); +} + +sub isnt_num { + my($class, $got, $dont_expect) = @_; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + return ($test, $test ? () : $class->_isnt_diag($got, '!=')); + } + + return $class->cmp_check($got, '!=', $dont_expect); +} + +sub regex_check { + my($class, $thing, $got_regex, $cmp) = @_; + + my $regex = is_regex($got_regex); + return (0, " '$got_regex' doesn't look much like a regex to me.") + unless defined $regex; + + my $ctx = context(); + my ($p, $file, $line) = $ctx->call; + + my $test; + my $mock = qq{#line $line "$file"\n}; + + my @warnings; + my ($success, $error) = try { + # No point in issuing an uninit warning, they'll see it in the diagnostics + no warnings 'uninitialized'; + ## no critic (BuiltinFunctions::ProhibitStringyEval) + protect { eval $mock . q{$test = $thing =~ /$regex/ ? 1 : 0; 1} || die $@ }; + }; + + return (0, "Exception: $error") unless $success; + + my $negate = $cmp eq '!~'; + + $test = !$test if $negate; + + unless($test) { + $thing = defined $thing ? "'$thing'" : 'undef'; + my $match = $negate ? "matches" : "doesn't match"; + my $diag = sprintf(qq{ \%s\n \%13s '\%s'\n}, $thing, $match, $got_regex); + return (0, $diag); + } + + return (1); +} + +sub can_check { + my ($us, $proto, $class, @methods) = @_; + + my @diag; + for my $method (@methods) { + my $ok; + my ($success, $error) = try { $ok = $proto->can($method) }; + if ($success) { + push @diag => " $class\->can('$method') failed" unless $ok; + } + else { + my $file = __FILE__; + $error =~ s/ at \Q$file\E line \d+//; + push @diag => " $class\->can('$method') failed with an exception:\n $error"; + } + } + + return (!@diag, @diag) +} + +sub isa_check { + my($us, $thing, $class, $thing_name) = @_; + + my ($whatami, $try_isa, $diag, $type); + if( !defined $thing ) { + $whatami = 'undef'; + $$thing_name = "undef" unless defined $$thing_name; + $diag = defined $thing ? "$$thing_name isn't a '$class'" : "$$thing_name isn't defined"; + } + elsif($type = blessed $thing) { + $whatami = 'object'; + $try_isa = 1; + $$thing_name = "An object of class '$type'" unless defined $$thing_name; + $diag = "$$thing_name isn't a '$class'"; + } + elsif($type = ref $thing) { + $whatami = 'reference'; + $$thing_name = "A reference of type '$type'" unless defined $$thing_name; + $diag = "$$thing_name isn't a '$class'"; + } + else { + $whatami = 'class'; + $try_isa = $thing && $thing !~ m/^\d+$/; + $$thing_name = "The class (or class-like) '$thing'" unless defined $$thing_name; + $diag = "$$thing_name isn't a '$class'"; + } + + my $ok; + if ($try_isa) { + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + my ($success, $error) = try { + my $ctx = context(); + my ($p, $f, $l) = $ctx->call; + eval qq{#line $l "$f"\n\$ok = \$thing\->isa(\$class); 1} || die $@; + }; + + die <<" WHOA" unless $success; +WHOA! I tried to call ->isa on your $whatami and got some weird error. +Here's the error. +$error + WHOA + } + else { + # Special case for isa_ok( [], "ARRAY" ) and like + $ok = UNIVERSAL::isa($thing, $class); + } + + return ($ok) if $ok; + return ($ok, " $diag\n"); +} + +sub new_check { + my($us, $class, $args, $object_name) = @_; + + $args ||= []; + + my $obj; + my($success, $error) = try { + my $ctx = context(); + my ($p, $f, $l) = $ctx->call; + eval qq{#line $l "$f"\n\$obj = \$class\->new(\@\$args); 1} || die $@; + }; + if($success) { + $object_name = "'$object_name'" if $object_name; + my ($ok, @diag) = $us->isa_check($obj, $class, \$object_name); + my $name = "$object_name isa '$class'"; + return ($obj, $name, $ok, @diag); + } + else { + $class = 'undef' unless defined $class; + return (undef, "$class->new() died", 0, " Error was: $error"); + } +} + +sub explain { + my ($us, @args) = @_; + protect { 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; + } + : $_ + } @args; +} + +sub _diag_fmt { + my( $class, $type, $val ) = @_; + + if( defined $$val ) { + if( $type eq 'eq' or $type eq 'ne' ) { + # quote and force string context + $$val = "'$$val'"; + } + else { + # force numeric context + unoverload_num($val); + } + } + else { + $$val = 'undef'; + } + + return; +} + +sub _is_diag { + my( $class, $got, $type, $expect ) = @_; + + $class->_diag_fmt( $type, $_ ) for \$got, \$expect; + + return <<"DIAGNOSTIC"; + got: $got + expected: $expect +DIAGNOSTIC +} + +sub _isnt_diag { + my( $class, $got, $type ) = @_; + + $class->_diag_fmt( $type, \$got ); + + return <<"DIAGNOSTIC"; + got: $got + expected: anything else +DIAGNOSTIC +} + + +sub _cmp_diag { + my( $class, $got, $type, $expect ) = @_; + + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + + return <<"DIAGNOSTIC"; + $got + $type + $expect +DIAGNOSTIC +} + +sub subtest { + my ($class, $name, $code, @args) = @_; + + my $ctx = context(); + + $ctx->throw("subtest()'s second argument must be a code ref") + unless $code && 'CODE' eq reftype($code); + + $ctx->child('push', $name); + $ctx->clear; + my $todo = $ctx->hide_todo; + + my ($succ, $err) = try { + { + no warnings 'once'; + local $Test::Builder::Level = 1; + $code->(@args); + } + + $ctx->set; + my $stream = $ctx->stream; + $ctx->done_testing unless $stream->plan || $stream->ended; + + require Test::Stream::ExitMagic; + { + local $? = 0; + Test::Stream::ExitMagic->new->do_magic($stream, $ctx->snapshot); + } + }; + + $ctx->set; + $ctx->restore_todo($todo); + # This sends the subtest event + my $st = $ctx->child('pop', $name); + + unless ($succ) { + die $err unless blessed($err) && $err->isa('Test::Stream::Event'); + $ctx->bail($err->reason) if $err->isa('Test::Stream::Event::Bail'); + } + + return $st->bool; +} + +1; + +__END__ + +=head1 NAME + +Test::More::Tools - Generic form of tools from Test::More. + +=head1 DESCRIPTION + +People used to call L<Test::More> tools within other testing tools. This mostly +works, but it generates events for each call. This package gives you access to +the implementations directly, without generating events for you. This allows +you to create a composite tool without generating extra events. + +=head1 SYNOPSYS + + use Test::More::Tools qw/tmt/; + use Test::Stream::Toolset qw/context/; + + # This is how Test::More::is is implemented + sub my_is { + my ($got, $want, $name) = @_; + + my $ctx = context; + + my ($ok, @diag) = tmt->is_eq($got, $want); + + $ctx->ok($ok, $name, \@diag); + } + +=head1 EXPORTS + +=over 4 + +=item $pkg = tmt() + +Simply returns the string 'Test::More::Tools'; + +=back + +=head1 CLASS METHODS + +Not all methods are listed. The ones that have been omitted are not intuitive, +and probably should not be used at all. + +=over 4 + +=item ($bool, @diag) = tmt->cmp_check($got, $op, $want) + +Check 2 values using the operator specified example: C<$got == $want> + +=item ($bool, @diag) = tmt->is_eq($got, $want) + +String compare. + +=item ($bool, @diag) = tmt->is_num($got, $want) + +Numeric compare. + +=item ($bool, @diag) = tmt->isnt_eq($got, $dont_want) + +String inequality compare. + +=item ($bool, @diag) = tmt->isnt_num($got, $dont_want) + +Numeric inequality compare. + +=item ($bool, @diag) = tmt->regex_check($got, $regex, $op) + +Regex compare. C<$op> may be C<=~> or C<!~>. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/MostlyLike.pm b/cpan/Test-Simple/lib/Test/MostlyLike.pm new file mode 100644 index 0000000000..76c6c470d8 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/MostlyLike.pm @@ -0,0 +1,292 @@ +package Test::MostlyLike; +use strict; +use warnings; + +use Test::Stream::Toolset; +use Test::Stream::Exporter; +default_exports qw/mostly_like/; +Test::Stream::Exporter->cleanup; + +use Test::More::DeepCheck::Tolerant; + +sub mostly_like { + my ($got, $want, $name) = @_; + + my $ctx = context(); + + unless( @_ == 2 or @_ == 3 ) { + my $msg = <<'WARNING'; +mostly_like() 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 + + $ctx->alert(sprintf $msg, scalar @_); + + $ctx->ok(0, undef, ['incorrect number of args']); + return 0; + } + + my ($ok, @diag) = Test::More::DeepCheck::Tolerant->check($got, $want); + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +1; + +__END__ + +=head1 NAME + +Test::MostlyLike - Relaxed checking of deep data structures. + +=head1 SYNOPSYS + + my $got = [qw/foo bar baz/]; + + mostly_like( + $got, + ['foo', qr/a/], + "Deeply nested structure matches (mostly)" + ); + +=head1 DESCRIPTION + +A tool based on C<is_deeply> from L<Test::More>. This tool produces nearly +identical diagnostics. This tool gives you extra control by letting you check +only the parts of the structure you care about, ignoring the rest. + +=head1 EXPORTS + +=over 4 + +=item $bool = mostly_like($got, $expect, $name) + +Generates a single ok event with diagnostics to help you find any failures. + +Got should be the data structure you want to test. $expect should be a data +structure representing what you expect to see. Unlike C<is_deeply> any keys in +C<$got> that do not I<exist> in C<$expect> will be ignored. + +=back + +=head1 WHAT TO EXPECT + +When an a blessed object is encountered in the C<$got> structure, any fields +listed in C<$expect> will be called as methods on the C<$got> object. See the +object/direct element access section below for bypassing this. + +Any keys or attributes in C<$got> will be ignored unless the also I<exist> in C<$expect> + +=head1 IGNORING THINGS YOU DO NOT CARE ABOUT + + my $got = { foo => 1, bar => 2 }; + my $expect = { foo => 1 }; + + mostly_like($got, $expect, "Ignores 'bar'"); + +If you want to check that a value is not set: + + my $got = { foo => 1, bar => 2 }; + my $expect = { foo => 1, bar => undef }; + + mostly_like($got, $expect, "Will fail since 'bar' has a value"); + +=head2 EXACT MATCHES + + my $got = 'foo'; + my $expect = 'foo'; + mostly_like($got, $expect, "Check a value directly"); + +Also works for deeply nested structures + + mostly_like( + [ + {stuff => 'foo bar baz'}, + ], + [ + {stuff => 'foo bar baz'}, + ], + "Check a value directly, nested" + ); + +=head2 REGEX MATCHES + + my $got = 'foo bar baz'; + my $expect = qr/bar/; + mostly_like($got, $expect, 'Match'); + +Works nested as well: + + mostly_like( + [ + {stuff => 'foo bar baz'}, + ], + [ + {stuff => qr/bar/}, + ], + "Check a value directly, nested" + ); + +=head2 ARRAY ELEMENT MATCHES + + my $got = [qw/foo bar baz/]; + my $exp = [qw/foo bar/]; + + mostly_like($got, $exp, "Ignores unspecified indexes"); + +You can also just check specific indexes: + + my $got = [qw/foo bar baz/]; + my $exp = { ':1' => 'bar' }; + + mostly_like($got, $exp, "Only checks array index 1"); + +When doing this the index must always be prefixed with ':'. + +=head2 HASH ELEMENT MATCHES + + my $got = { foo => 1, bar => 2 }; + my $exp = { foo => 1 }; + + mostly_like($got, $exp, "Only checks foo"); + +=head2 OBJECT METHOD MATCHES + +=head3 UNALTERED + + sub foo { $_[0]->{foo} } + + my $got = bless {foo => 1}, __PACKAGE__; + my $exp = { foo => 1 }; + + mostly_like($got, $exp, 'Checks the return of $got->foo()'); + +=head3 WRAPPED + +Sometimes methods return lists, in such cases you can wrap them in arrayrefs or +hashrefs: + + sub list { qw/foo bar baz/ } + sub dict { foo => 0, bar => 1, baz => 2 } + + my $got = bless {}, __PACKAGE__; + my $exp = { + '[list]' => [ qw/foo bar baz/ ], + '[dict]' => { foo => 0, bar => 1, baz => 2 }, + }; + mostly_like($got, $exp, "Wrapped the method calls"); + +=head3 DIRECT ELEMENT ACCESS + +Sometimes you want to ignore the methods and get the hash value directly. + + sub foo { die "do not call me" } + + my $got = bless { foo => 'secret' }, __PACKAGE__; + my $exp = { ':foo' => 'secret' }; + + mostly_like($got, $exp, "Did not call the fatal method"); + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +=item Test::MostlyLike + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index a8cfb8a9a4..84aebed43f 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -1,17 +1,65 @@ package Test::Simple; -use 5.006; +use 5.008001; use strict; +use warnings; -our $VERSION = '1.001009'; +our $VERSION = '1.301001_071'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Builder::Module 0.99; -our @ISA = qw(Test::Builder::Module); -our @EXPORT = qw(ok); +use Test::Stream 1.301001_071 '-internal'; +use Test::Stream::Toolset; + +use Test::Stream::Exporter; +default_exports qw/ok/; +Test::Stream::Exporter->cleanup; + +sub before_import { + my $class = shift; + my ($importer, $list) = @_; + + my $meta = init_tester($importer); + my $context = context(1); + my $idx = 0; + my $other = []; + while ($idx <= $#{$list}) { + my $item = $list->[$idx++]; + + if (defined $item and $item eq 'no_diag') { + Test::Stream->shared->set_no_diag(1); + } + elsif ($item eq 'tests') { + $context->plan($list->[$idx++]); + } + elsif ($item eq 'skip_all') { + $context->plan(0, 'SKIP', $list->[$idx++]); + } + elsif ($item eq 'no_plan') { + $context->plan(0, 'NO PLAN'); + } + elsif ($item eq 'import') { + push @$other => @{$list->[$idx++]}; + } + else { + $context->throw("Unknown option: $item"); + } + } + + @$list = @$other; + + return; +} + +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + my $ctx = context(); + return $ctx->ok(@_); + return $_[0] ? 1 : 0; +} -my $CLASS = __PACKAGE__; +1; + +__END__ =head1 NAME @@ -23,7 +71,6 @@ Test::Simple - Basic utilities for writing tests. ok( $foo eq $bar, 'foo is bar' ); - =head1 DESCRIPTION ** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> ** @@ -74,12 +121,6 @@ All tests are run in scalar context. So this: 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 @@ -194,12 +235,14 @@ programs and things will still work). Look in L<Test::More>'s SEE ALSO for more testing modules. -=head1 AUTHORS +=encoding utf8 -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. -=head1 MAINTAINERS +=head1 MAINTAINER =over 4 @@ -207,15 +250,87 @@ E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. =back +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + =head1 COPYRIGHT +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. -This program is free software; you can redistribute it and/or +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> -=cut +=item Test::use::ok -1; +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream.pm b/cpan/Test-Simple/lib/Test/Stream.pm new file mode 100644 index 0000000000..8af0dd472d --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream.pm @@ -0,0 +1,1101 @@ +package Test::Stream; +use strict; +use warnings; + +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Stream::Threads; +use Test::Stream::IOSets; +use Test::Stream::Util qw/try/; +use Test::Stream::Carp qw/croak confess carp/; +use Test::Stream::Meta qw/MODERN ENCODING init_tester/; + +use Test::Stream::ArrayBase( + accessors => [qw{ + no_ending no_diag no_header + pid tid + state + subtests subtest_todo subtest_exception + subtest_tap_instant + subtest_tap_delayed + mungers + listeners + follow_ups + bailed_out + exit_on_disruption + use_tap use_legacy _use_fork + use_numbers + io_sets + event_id + in_subthread + }], +); + +sub STATE_COUNT() { 0 } +sub STATE_FAILED() { 1 } +sub STATE_PLAN() { 2 } +sub STATE_PASSING() { 3 } +sub STATE_LEGACY() { 4 } +sub STATE_ENDED() { 5 } + +sub OUT_STD() { 0 } +sub OUT_ERR() { 1 } +sub OUT_TODO() { 2 } + +use Test::Stream::Exporter; +exports qw/ + OUT_STD OUT_ERR OUT_TODO + STATE_COUNT STATE_FAILED STATE_PLAN STATE_PASSING STATE_LEGACY STATE_ENDED +/; +default_exports qw/ cull tap_encoding /; +Test::Stream::Exporter->cleanup; + +sub tap_encoding { + my ($encoding) = @_; + + require Encode; + + croak "encoding '$encoding' is not valid, or not available" + unless $encoding eq 'legacy' || Encode::find_encoding($encoding); + + require Test::Stream::Context; + my $ctx = Test::Stream::Context::context(); + $ctx->stream->io_sets->init_encoding($encoding); + + my $meta = init_tester($ctx->package); + $meta->[ENCODING] = $encoding; +} + +sub cull { + require Test::Stream::Context; + my $ctx = Test::Stream::Context::context(); + $ctx->stream->fork_cull(); +} + +sub before_import { + my $class = shift; + my ($importer, $list) = @_; + + if (@$list && $list->[0] eq '-internal') { + shift @$list; + return; + } + + my $meta = init_tester($importer); + $meta->[MODERN] = 1; + + my $other = []; + my $idx = 0; + my $stream = $class->shared; + + while ($idx <= $#{$list}) { + my $item = $list->[$idx++]; + next unless $item; + + if ($item eq 'subtest_tap') { + my $val = $list->[$idx++]; + if (!$val || $val eq 'none') { + $stream->set_subtest_tap_instant(0); + $stream->set_subtest_tap_delayed(0); + } + elsif ($val eq 'instant') { + $stream->set_subtest_tap_instant(1); + $stream->set_subtest_tap_delayed(0); + } + elsif ($val eq 'delayed') { + $stream->set_subtest_tap_instant(0); + $stream->set_subtest_tap_delayed(1); + } + elsif ($val eq 'both') { + $stream->set_subtest_tap_instant(1); + $stream->set_subtest_tap_delayed(1); + } + else { + croak "'$val' is not a valid option for '$item'"; + } + } + elsif ($item eq 'utf8') { + $stream->io_sets->init_encoding('utf8'); + $meta->[ENCODING] = 'utf8'; + } + elsif ($item eq 'encoding') { + my $encoding = $list->[$idx++]; + + croak "encoding '$encoding' is not valid, or not available" + unless Encode::find_encoding($encoding); + + $stream->io_sets->init_encoding($encoding); + $meta->[ENCODING] = $encoding; + } + elsif ($item eq 'enable_fork') { + $stream->use_fork; + } + else { + push @$other => $item; + } + } + + @$list = @$other; + + return; +} + +sub plan { $_[0]->[STATE]->[-1]->[STATE_PLAN] } +sub count { $_[0]->[STATE]->[-1]->[STATE_COUNT] } +sub failed { $_[0]->[STATE]->[-1]->[STATE_FAILED] } +sub ended { $_[0]->[STATE]->[-1]->[STATE_ENDED] } +sub legacy { $_[0]->[STATE]->[-1]->[STATE_LEGACY] } + +sub is_passing { + my $self = shift; + + if (@_) { + ($self->[STATE]->[-1]->[STATE_PASSING]) = @_; + } + + my $current = $self->[STATE]->[-1]->[STATE_PASSING]; + + my $plan = $self->[STATE]->[-1]->[STATE_PLAN]; + return $current if $self->[STATE]->[-1]->[STATE_ENDED]; + return $current unless $plan; + return $current unless $plan->max; + return $current if $plan->directive && $plan->directive eq 'NO PLAN'; + return $current unless $self->[STATE]->[-1]->[STATE_COUNT] > $plan->max; + + return $self->[STATE]->[-1]->[STATE_PASSING] = 0; +} + +sub init { + my $self = shift; + + $self->[PID] = $$; + $self->[TID] = get_tid(); + $self->[STATE] = [[0, 0, undef, 1]]; + $self->[USE_TAP] = 1; + $self->[USE_NUMBERS] = 1; + $self->[IO_SETS] = Test::Stream::IOSets->new; + $self->[EVENT_ID] = 1; + $self->[NO_ENDING] = 1; + $self->[SUBTESTS] = []; + + $self->[SUBTEST_TAP_INSTANT] = 1; + $self->[SUBTEST_TAP_DELAYED] = 0; + + $self->use_fork if USE_THREADS; + + $self->[EXIT_ON_DISRUPTION] = 1; +} + +{ + my ($root, @stack, $magic); + + END { + $root->fork_cull if $root && $root->_use_fork && $$ == $root->[PID]; + $magic->do_magic($root) if $magic && $root && !$root->[NO_ENDING] + } + + sub _stack { @stack } + + sub shared { + my ($class) = @_; + return $stack[-1] if @stack; + + @stack = ($root = $class->new(0)); + $root->[NO_ENDING] = 0; + + require Test::Stream::Context; + require Test::Stream::Event::Finish; + require Test::Stream::ExitMagic; + require Test::Stream::ExitMagic::Context; + + $magic = Test::Stream::ExitMagic->new; + + return $root; + } + + sub clear { + $root->[NO_ENDING] = 1; + $root = undef; + $magic = undef; + @stack = (); + } + + sub intercept_start { + my $class = shift; + my ($new) = @_; + + my $old = $stack[-1]; + + unless($new) { + $new = $class->new(); + + $new->set_exit_on_disruption(0); + $new->set_use_tap(0); + $new->set_use_legacy(0); + } + + push @stack => $new; + + return ($new, $old); + } + + sub intercept_stop { + my $class = shift; + my ($current) = @_; + croak "Stream stack inconsistency" unless $current == $stack[-1]; + pop @stack; + } +} + +sub intercept { + my $class = shift; + my ($code) = @_; + + croak "The first argument to intercept must be a coderef" + unless $code && ref $code && ref $code eq 'CODE'; + + my ($new, $old) = $class->intercept_start(); + my ($ok, $error) = try { $code->($new, $old) }; + $class->intercept_stop($new); + + die $error unless $ok; + return $ok; +} + +sub listen { + my $self = shift; + for my $sub (@_) { + next unless $sub; + + croak "listen only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->[LISTENERS]} => $sub; + } +} + +sub munge { + my $self = shift; + for my $sub (@_) { + next unless $sub; + + croak "munge only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->[MUNGERS]} => $sub; + } +} + +sub follow_up { + my $self = shift; + for my $sub (@_) { + next unless $sub; + + croak "follow_up only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->[FOLLOW_UPS]} => $sub; + } +} + +sub use_fork { + require File::Temp; + require Storable; + + $_[0]->[_USE_FORK] ||= File::Temp::tempdir(CLEANUP => 0); + confess "Could not get a temp dir" unless $_[0]->[_USE_FORK]; + if ($^O eq 'VMS') { + require VMS::Filespec; + $_[0]->[_USE_FORK] = VMS::Filespec::unixify($_[0]->[_USE_FORK]); + } + return 1; +} + +sub fork_out { + my $self = shift; + + my $tempdir = $self->[_USE_FORK]; + confess "Fork support has not been turned on!" unless $tempdir; + + my $tid = get_tid(); + + for my $event (@_) { + next unless $event; + next if $event->isa('Test::Stream::Event::Finish'); + + # First write the file, then rename it so that it is not read before it is ready. + my $name = $tempdir . "/$$-$tid-" . ($self->[EVENT_ID]++); + my ($ret, $err) = try { Storable::store($event, $name) }; + # Temporary to debug an error on one cpan-testers box + unless ($ret) { + require Data::Dumper; + confess(Data::Dumper::Dumper({ error => $err, event => $event})); + } + rename($name, "$name.ready") || confess "Could not rename file '$name' -> '$name.ready'"; + } +} + +sub fork_cull { + my $self = shift; + + confess "fork_cull() can only be called from the parent process!" + if $$ != $self->[PID]; + + confess "fork_cull() can only be called from the parent thread!" + if get_tid() != $self->[TID]; + + my $tempdir = $self->[_USE_FORK]; + confess "Fork support has not been turned on!" unless $tempdir; + + opendir(my $dh, $tempdir) || croak "could not open temp dir ($tempdir)!"; + + my @files = sort readdir($dh); + for my $file (@files) { + next if $file =~ m/^\.+$/; + next unless $file =~ m/\.ready$/; + + # Untaint the path. + my $full = "$tempdir/$file"; + ($full) = ($full =~ m/^(.*)$/gs); + + my $obj = Storable::retrieve($full); + confess "Empty event object found '$full'" unless $obj; + + if ($ENV{TEST_KEEP_TMP_DIR}) { + rename($full, "$full.complete") + || confess "Could not rename file '$full', '$full.complete'"; + } + else { + unlink($full) || die "Could not unlink file: $file"; + } + + my $cache = $self->_update_state($self->[STATE]->[0], $obj); + $self->_process_event($obj, $cache); + $self->_finalize_event($obj, $cache); + } + + closedir($dh); +} + +sub done_testing { + my $self = shift; + my ($ctx, $num) = @_; + my $state = $self->[STATE]->[-1]; + + if (my $old = $state->[STATE_ENDED]) { + my ($p1, $f1, $l1) = $old->call; + $ctx->ok(0, "done_testing() was already called at $f1 line $l1"); + return; + } + + if ($self->[FOLLOW_UPS]) { + $_->($ctx) for @{$self->[FOLLOW_UPS]}; + } + + $state->[STATE_ENDED] = $ctx->snapshot; + + my $ran = $state->[STATE_COUNT]; + my $plan = $state->[STATE_PLAN] ? $state->[STATE_PLAN]->max : 0; + + if (defined($num) && $plan && $num != $plan) { + $ctx->ok(0, "planned to run $plan but done_testing() expects $num"); + return; + } + + $ctx->plan($num || $plan || $ran) unless $state->[STATE_PLAN]; + + if ($plan && $plan != $ran) { + $state->[STATE_PASSING] = 0; + return; + } + + if ($num && $num != $ran) { + $state->[STATE_PASSING] = 0; + return; + } + + unless ($ran) { + $state->[STATE_PASSING] = 0; + return; + } +} + +sub send { + my ($self, $e) = @_; + + # Subtest state management + if ($e->isa('Test::Stream::Event::Child')) { + if ($e->action eq 'push') { + $e->context->note("Subtest: " . $e->name) if $self->[SUBTEST_TAP_INSTANT] && !$e->no_note; + + push @{$self->[STATE]} => [0, 0, undef, 1]; + push @{$self->[SUBTESTS]} => []; + push @{$self->[SUBTEST_TODO]} => $e->context->in_todo; + push @{$self->[SUBTEST_EXCEPTION]} => undef; + + return $e; + } + else { + pop @{$self->[SUBTEST_TODO]}; + my $events = pop @{$self->[SUBTESTS]} || confess "Unbalanced subtest stack (events)!"; + my $state = pop @{$self->[STATE]} || confess "Unbalanced subtest stack (state)!"; + confess "Child pop left the stream without a state!" unless @{$self->[STATE]}; + + $e = Test::Stream::Event::Subtest->new_from_pairs( + context => $e->context, + created => $e->created, + events => $events, + state => $state, + name => $e->name, + exception => pop @{$self->[SUBTEST_EXCEPTION]}, + ); + } + } + + my $cache = $self->_update_state($self->[STATE]->[-1], $e); + + # Subtests get dibbs on events + if (@{$self->[SUBTESTS]}) { + $e->context->set_diag_todo(1) if $self->[SUBTEST_TODO]->[-1]; + $e->set_in_subtest(scalar @{$self->[SUBTESTS]}); + push @{$self->[SUBTESTS]->[-1]} => $e; + + $self->_render_tap($cache) if $self->[SUBTEST_TAP_INSTANT] && !$cache->{no_out}; + } + elsif($self->[_USE_FORK] && ($$ != $self->[PID] || get_tid() != $self->[TID])) { + $self->fork_out($e); + } + else { + $self->_process_event($e, $cache); + } + + $self->_finalize_event($e, $cache); + + return $e; +} + +sub _update_state { + my ($self, $state, $e) = @_; + my $cache = {tap_event => $e, state => $state}; + + if ($e->isa('Test::Stream::Event::Ok')) { + $cache->{do_tap} = 1; + $state->[STATE_COUNT]++; + if (!$e->bool) { + $state->[STATE_FAILED]++; + $state->[STATE_PASSING] = 0; + } + } + elsif (!$self->[NO_HEADER] && $e->isa('Test::Stream::Event::Finish')) { + if ($self->[FOLLOW_UPS]) { + $_->($e->context) for @{$self->[FOLLOW_UPS]}; + } + + $state->[STATE_ENDED] = $e->context->snapshot; + + my $plan = $state->[STATE_PLAN]; + if ($plan && $e->tests_run && $plan->directive eq 'NO PLAN') { + $plan->set_max($state->[STATE_COUNT]); + $plan->set_directive(undef); + $cache->{tap_event} = $plan; + $cache->{do_tap} = 1; + } + else { + $cache->{do_tap} = 0; + $cache->{no_out} = 1; + } + } + elsif ($self->[NO_DIAG] && $e->isa('Test::Stream::Event::Diag')) { + $cache->{no_out} = 1; + } + elsif ($e->isa('Test::Stream::Event::Plan')) { + $cache->{is_plan} = 1; + + if($self->[NO_HEADER]) { + $cache->{no_out} = 1; + } + elsif(my $existing = $state->[STATE_PLAN]) { + my $directive = $existing ? $existing->directive : ''; + + if ($existing && (!$directive || $directive eq 'NO PLAN')) { + my ($p1, $f1, $l1) = $existing->context->call; + my ($p2, $f2, $l2) = $e->context->call; + die "Tried to plan twice!\n $f1 line $l1\n $f2 line $l2\n"; + } + } + + my $directive = $e->directive; + $cache->{no_out} = 1 if $directive && $directive eq 'NO PLAN'; + } + + push @{$state->[STATE_LEGACY]} => $e if $self->[USE_LEGACY]; + + $cache->{number} = $state->[STATE_COUNT]; + + return $cache; +} + +sub _process_event { + my ($self, $e, $cache) = @_; + + if ($self->[MUNGERS]) { + $_->($self, $e) for @{$self->[MUNGERS]}; + } + + $self->_render_tap($cache) unless $cache->{no_out}; + + if ($self->[LISTENERS]) { + $_->($self, $e) for @{$self->[LISTENERS]}; + } +} + +sub _render_tap { + my ($self, $cache) = @_; + + return if $^C; + return unless $self->[USE_TAP]; + my $e = $cache->{tap_event}; + return unless $cache->{do_tap} || $e->can('to_tap'); + + my $num = $self->use_numbers ? $cache->{number} : undef; + confess "XXX" unless $e->can('to_tap'); + my @sets = $e->to_tap($num, $self->[SUBTEST_TAP_DELAYED]); + + my $in_subtest = $e->in_subtest || 0; + my $indent = ' ' x $in_subtest; + + for my $set (@sets) { + my ($hid, $msg) = @$set; + next unless $msg; + my $enc = $e->encoding || confess "Could not find encoding!"; + my $io = $self->[IO_SETS]->{$enc}->[$hid] || confess "Could not find IO $hid for $enc"; + + local($\, $", $,) = (undef, ' ', ''); + $msg =~ s/^/$indent/mg if $in_subtest; + print $io $msg; + } +} + +sub _finalize_event { + my ($self, $e, $cache) = @_; + + if ($cache->{is_plan}) { + $cache->{state}->[STATE_PLAN] = $e; + return unless $e->directive; + return unless $e->directive eq 'SKIP'; + + $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest; + + die $e if $e->in_subtest || !$self->[EXIT_ON_DISRUPTION]; + exit 0; + } + elsif (!$cache->{do_tap} && $e->isa('Test::Stream::Event::Bail')) { + $self->[BAILED_OUT] = $e; + $self->[NO_ENDING] = 1; + + $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest; + + die $e if $e->in_subtest || !$self->[EXIT_ON_DISRUPTION]; + exit 255; + } +} + +sub _reset { + my $self = shift; + + return unless $self->pid != $$ || $self->tid != get_tid(); + + $self->[PID] = $$; + $self->[TID] = get_tid(); + if (USE_THREADS || $self->[_USE_FORK]) { + $self->[_USE_FORK] = undef; + $self->use_fork; + } + $self->[STATE] = [[0, 0, undef, 1]]; +} + +sub CLONE { + for my $stream (_stack()) { + next unless defined $stream->pid; + next unless defined $stream->tid; + + next if $$ == $stream->pid && get_tid() == $stream->tid; + + $stream->[IN_SUBTHREAD] = 1; + } +} + +sub DESTROY { + my $self = shift; + + return if $self->in_subthread; + + my $dir = $self->[_USE_FORK] || return; + + return unless defined $self->pid; + return unless defined $self->tid; + + return unless $$ == $self->pid; + return unless get_tid() == $self->tid; + + if ($ENV{TEST_KEEP_TMP_DIR}) { + print STDERR "# Not removing temp dir: $dir\n"; + return; + } + + opendir(my $dh, $dir) || confess "Could not open temp dir! ($dir)"; + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + die "Unculled event! You ran tests in a child process, but never pulled them in!\n" + if $file !~ m/\.complete$/; + unlink("$dir/$file") || confess "Could not unlink file: '$dir/$file'"; + } + closedir($dh); + rmdir($dir) || warn "Could not remove temp dir ($dir)"; +} + +sub STORABLE_freeze { + my ($self, $cloning) = @_; + return if $cloning; + return ($self); +} + +sub STORABLE_thaw { + my ($self, $cloning, @vals) = @_; + return if $cloning; + return Test::Stream->shared; +} + + +1; + +__END__ + +=head1 NAME + +Test::Stream - A modern infrastructure for testing. + +=head1 SYNOPSYS + + # Enables modern enhancements such as forking support and TAP encoding. + # Also turns off expensive legacy support. + use Test::Stream; + use Test::More; + + # ... Tests ... + + done_testing; + +=head1 FEATURES + +When you load Test::Stream inside your test file you prevent Test::More from +turning on some expensive legacy support. You will also get warnings if your +code, or any other code you load uses deprecated or discouraged practices. + +=head1 IMPORT ARGUMENTS + +Any import argument not recognised will be treated as an export, if it is not a +valid export an exception will be thrown. + +=over 4 + +=item '-internal' + +This argument, I<when given first>, will prevent the import process from +turning on enhanced features. This is mainly for internal use (thus the name) +in order to access/load Test::Stream. + +=item subtest_tap => 'none' + +Do not show events within subtests, just the subtest result itself. + +=item subtest_tap => 'instant' + +Show events as they happen (this is how legacy Test::More worked). This is the +default. + +=item subtest_tap => 'delayed' + +Show events within subtest AFTER the subtest event itself is complete. + +=item subtest_tap => 'both' + +Show events as they happen, then also display them after. + +=item 'enable_fork' + +Turns on support for code that forks. This is not activated by default because +it adds ~30ms to the Test::More compile-time, which can really add up in large +test suites. Turn it on only when needed. + +=item 'utf8' + +Set the TAP encoding to utf8 + +=item encoding => '...' + +Set the TAP encoding. + +=back + +=head1 EXPORTS + +=head2 DEFAULT EXPORTS + +=over 4 + +=item tap_encoding( $ENCODING ) + +Set the tap encoding from this point on. + +=item cull + +Bring in results from child processes/threads. This is automatically done +whenever a context is obtained, but you may wish to do it on demand. + +=back + +=head2 CONSTANTS + +none of these are exported by default you must request them + +=over + +=item OUT_STD + +=item OUT_ERR + +=item OUT_TODO + +These are indexes of specific IO handles inside an IO set (each encoding has an +IO set). + +=item STATE_COUNT + +=item STATE_FAILED + +=item STATE_PLAN + +=item STATE_PASSING + +=item STATE_LEGACY + +=item STATE_ENDED + +These are indexes into the STATE array present in the stream. + +=back + +=head1 THE STREAM STACK AND METHODS + +At any point there can be any number of streams. Most streams will be present +in the stream stack. The stack is managed via a collection of class methods. +You can always access the "current" or "central" stream using +Test::Stream->shared. If you want your events to go where they are supposed to +then you should always send them to the shared stream. + +It is important to note that any toogle, control, listener, munger, etc. +applied to a stream will effect only that stream. Independant streams, streams +down the stack, and streams added later will not get any settings from other +stacks. Keep this in mind if you take it upon yourself to modify the stream +stack. + +=head2 TOGGLES AND CONTROLS + +=over 4 + +=item $stream->use_fork + +Turn on forking support (it cannot be turned off). + +=item $stream->set_subtest_tap_instant($bool) + +=item $bool = $stream->subtest_tap_instant + +Render subtest events as they happen. + +=item $stream->set_subtest_tap_delayed($bool) + +=item $bool = $stream->subtest_tap_delayed + +Render subtest events when printing the result of the subtest + +=item $stream->set_exit_on_disruption($bool) + +=item $bool = $stream->exit_on_disruption + +When true, skip_all and bailout will call exit. When false the bailout and +skip_all events will be thrown as exceptions. + +=item $stream->set_use_tap($bool) + +=item $bool = $stream->use_tap + +Turn TAP rendering on or off. + +=item $stream->set_use_legacy($bool) + +=item $bool = $stream->use_legacy + +Turn legacy result storing on and off. + +=item $stream->set_use_numbers($bool) + +=item $bool = $stream->use_numbers + +Turn test numbers on and off. + +=back + +=head2 SENDING EVENTS + + Test::Stream->shared->send($event) + +The C<send()> method is used to issue an event to the stream. This method will +handle thread/fork sych, mungers, listeners, TAP output, etc. + +=head2 ALTERING EVENTS + + Test::Stream->shared->munge(sub { + my ($stream, $event) = @_; + + ... Modify the event object ... + + # return is ignored. + }); + +Mungers can never be removed once added. The return from a munger is ignored. +Any changes you wish to make to the object must be done directly by altering +it in place. The munger is called before the event is rendered as TAP, and +AFTER the event has made any necessary state changes. + +=head2 LISTENING FOR EVENTS + + Test::Stream->shared->listen(sub { + my ($stream, $event) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +Listeners can never be removed once added. The return from a listener is +ignored. Changing an event in a listener is not something you should ever do, +though no protections are in place to prevent it (this may change!). The +listeners are called AFTER the event has been rendered as TAP. + +=head2 POST-TEST BEHAVIORS + + Test::Stream->shared->follow_up(sub { + my ($context) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, when the stream recieves a finish event. There are 2 ways a finish event can occur: + +=over 4 + +=item done_testing + +A finish event is generated when you call done_testing. The finish event occurs +before the plan is output. + +=item EXIT MAGIC + +A finish event is generated when the Test::Stream END block is called, just +before cleanup. This event will not happen if it was already geenerated by a +call to done_testing. + +=back + +=head2 OTHER METHODS + +=over + +=item $stream->state + +Get the current state of the stream. The state is an array where specific +indexes have specific meanings. These indexes are managed via constants. + +=item $stream->plan + +Get the plan event, if a plan has been issued. + +=item $stream->count + +Get the test count so far. + +=item $stream->failed + +Get the number of failed tests so far. + +=item $stream->ended + +Get the context in which the tests ended, if they have ended. + +=item $stream->legacy + +Used internally to store events for legacy support. + +=item $stream->is_passing + +Check if the test is passing its plan. + +=item $stream->done_testing($context, $max) + +Tell the stream we are done testing. + +=item $stream->fork_cull + +Gather events from other threads/processes. + +=back + +=head2 STACK METHODS AND INTERCEPTING EVENTS + +=over 4 + +=item $stream = Test::Stream->shared + +Get the current shared stream. The shared stream is the stream at the top of +the stack. + +=item Test::Stream->clear + +Completely remove the stream stack. It is very unlikely you will ever want to +do this. + +=item ($new, $old) = Test::Stream->intercept_start($new) + +=item ($new, $old) = Test::Stream->intercept_start + +Push a new stream to the top of the stack. If you do not provide a stack a new +one will be created for you. If you have one created for you it will have the +following differences from a default stack: + + $new->set_exit_on_disruption(0); + $new->set_use_tap(0); + $new->set_use_legacy(0); + +=item Test::Stream->intercept_stop($top) + +Pop the stack, you must pass in the instance you expect to be popped, there +will be an exception if they do not match. + +=item Test::Stream->intercept(sub { ... }) + + Test::Stream->intercept(sub { + my ($new, $old) = @_; + + ... + }); + +Temporarily push a new stream to the top of the stack. The codeblock you pass +in will be run. Once your codelbock returns the stack will be popped and +restored to the previous state. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Architecture.pod b/cpan/Test-Simple/lib/Test/Stream/Architecture.pod new file mode 100644 index 0000000000..b98ce503ed --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Architecture.pod @@ -0,0 +1,444 @@ +=head1 NAME + +Test::Stream::Architecture - Overview of how the Test-More dist works. + +=head1 DESCRIPTION + +This is the document that explains the architecture of Test::More and all the +stuff driving it under the hood. + +=head1 KEY COMPONENTS + +This is the list of primary components and their brief description, The most +critical ones will have more details in later sections. + +=over 4 + +=item Test::More + +=item Test::Simple + +These are the primary public interfaces for anyone who wishes to write tests. + +=item Test::More::Tools + +All of the tools Test::More provides have been relocated and refactored into +Test::More::Tools in such a way as to make them generic and reusable. This +means you can use them without firing off events, you can then fire off your +own events compiled from multiple tools. In many cases this is what tool +builders actually want, but instead they settle for bumping C<$Level> and +calling is/like/ok and producing extra events. + +=item Test::Builder + +This B<used> to be the main under the hood module for anyone who wished to +write a L<Test::More> compatible test library. It still works, and should be +fully functional and backwards compatible. It is however discouraged as it is +mostly a compatability wrapper. + +=item Test::Stream + +This is the B<new> heart and soul of the Test::* architecture. However it is +not the primary interface. This module is responsible for collecting all events +from all threads and processes, then forwarding them to TAP and any added +listeners. + +=item Test::Stream::IOSets + +This module is used to manage the IO handles to which all TAP is sent. +Test::Builder cloned STDERR and STDOUT, then applied various magic to them. +This module provides that legacy support while also adding support for utf8 and +other encodings. By default all TAP goes to the 'legacy' outputs, which mimick +what Test::Builder has always done. The 'legacy' outputs are also what get +altered if someone uses the Test::Builder->output interface. + +=item Test::Stream::Toolset + +This is the primary interface a test module author should use. It ties together +some key functions you should use. It proved 3 critical functions: + + is_tester($package) + + init_tester($package) + + my $ctx = context(); + +=item Test::Stream::Context + +This is the primary interface as far as generating events goes. Every test +function should grab a context, and use it to generate events. + +Once a context object is created (the normal way) it is remembered, and +anything that requests a context object will obtain the same instance. However +once the instance is destroyed (end of your test function) it is forgotten, the +next test function to run will then obtain a new context instance. + +=item Test::Stream::Event + +=item Test::Stream::Event::Ok + +=item Test::Stream::Event::Diag + +=item Test::Stream::Event::Note + +=item Test::Stream::Event::* + +All events generated by Test::More and other test tools now boil down to a +proper object. All events must use Test::Stream::Event as a base. + +=item Test::Stream::ArrayBase + +This is the L<Moose> of Test::Stream. It is responsible for generating +accessors and similar work. Unlike moose and others it uses an arrayref as the +underlying object. This design decision was made to improve performance. +Performance was a real problem in some early alphas, the gains from the +decision are huge. + +=item Test::Stream::Tester + +This is actually what spawned the ideas for the new Test::Stream work. This is +a module that lets you validate your testing tools. + +=back + +=head1 THE STREAM OBJECT + +=over 4 + +=item L<Test::Stream> + +=back + +=head2 HISTORY + +L<Test::Builder> is/was a singleton. The singleton model was chosen to solve +the problem of synchronizing everything to a central location. Ultimately all +results need to make their way to a central place that can assign them a +number, and shove them through the correct output. + +The singleton model proved to be a major headache. + +Intercepting events typically meant replacing the singleton permanently +(Test::Tester) or for a limited scope. Another option people took +(Test::Builder::Tester) was to simply replace the IO handles Test::Builder was +tracking. + +Test::Builder did not provide any real mechanisms for altering events before +processing them, or for intercepting them before they were turned into TAP. As +a result many modules have monkeypatched Test::Builder, particularily the +C<ok()> method. + +=head2 CURRENT DESIGN + +Test::Stream unfortunately must still act as a singleton (mostly). But this +time the design was to put as little as possible into the singleton. + +=head3 RESPONSIBILITIES OF TEST::STREAM + +Test::Stream has 4 main jobs: + +=over 4 + +=item Collect events from all threads and processes into 1 place + + $stream->send($event); + +The send() method will ensure that the event gets to the right place, no matter +what thread or process you are in. (Forking support must be turned on, it is +off by default). + +B<Note:> This method is key to performance. This method and everything it calls +must remain as lean and tight as possible. + +=item Provide a pre-output hook for altering events + + $stream->munge(sub { my ($stream, $event) = @_; ... }) + +This lets you modify events before they are turned into output. You cannot +remove the event, nor can you add events. Mungers are additive, and proceessed +in the order they are added. + +There is not currently any way to remove a munger. + +B<Note:> each munger is called in a loop in the C<send()> method, so keep it as +fast and small as possible. + +=item Forward all events to listeners (including TAP output) + + $stream->listen(sub { my ($stream, $event) = @_; .... }) + +This lets you add a listener. All events that come to the stream object will be +sent to all listeners. + +There is not currently any way to remove a listener. + +B<Note:> each listener is called in a loop in the C<send()> method, so keep it is +fast and small as possible. + +=item Maintaining the legacy exit behavior from Test::Builder + +This is primarily setting $? to the number of tests that failed, up to 255, as +well as providing other output such as missing a plan. + +=back + +=head3 SEMI-SINGLETON MODEL + +Test::Stream has a semi-singleton model. Instead of 1 singleton, it is a +singleton stack. Anything that wants to send an event to the B<current> acting +stream should send it to the stream returned by C<< Test::Stream->shared >>. +Nothing should ever cache this result as the B<current> stream may change. + +This mechanism is primarily used for intercepting, and hiding, all events for a +limited scope. L<Test::Stream::Tester> uses this to push a stream onto the stack so +that you can generate events that do not go to the listeners or TAP. Once the +stack is popped the previous stream is restored allowing you to generate real +events. + +You can also create new Test::Stream objects at-will that are not present in +the stack, this lets you create alternate streams for any purpose you want. + +=head1 THE CONTEXT OBJECT + +=over 4 + +=item L<Test::Stream::Context> + +=back + +This module is responsbile for 2 things, knowing where to report errors, and +making it easy to issue events. + +=head2 ERROR REPORTING + +To get the context you use the C<context()> function. + + sub ok { + my $context = context(); + ... + } + + ok() # Errors are reported here. + +If there is a context already in play, that instance will be returned. +Otherwise a new context will be returned. The context assumes that the stack +level just above your call is where errors should be reported. + +You can optionally provide an integer as the only argument, in which case that +number will be added to the C<caller()> call to find the correct frame for +reporting. This will be completely ignored if there is already an active +context. + + sub ok { + my $context = context(); + ... + } + + sub my_ok { + my $context = context(); + ok(...); + } + + my_ok(); + +In the example above c<my_ok()> generates a new context, then it calls C<ok()>, +in this case both function will have the same context object, the one generated +by my_ok. The result is that C<ok> will report errors to the correct place. + +=head3 IMPLEMENTATION + +There is a variable C<$CURRENT> in C<Test::Stream::Context>, it is a lexical, +so you can not touch it directly. When the C<context()> function is called, it +first checks if $CURRENT is set, if so it returns that. If there is no current +context it generates a new one. + +When a new context is generated, it is assigned to C<$CURRENT>, but then the +reference is weakened. This means that once the returned copy falls out of +scope, or is otherwise removed, C<$CURRENT> will vanish on its own. This means +that so long as you hold on to your context object, anything you call will find +it. + +B<The caveat> here is that if you decide to hold on to your context beyond +your scope, you could sabatoge any future test functions. If you need to hold +on to a context you need to call C<< $context->snapshot >>, and store the +cloned object it returns. In general you should not need to do this, event +objects all store the context, but do so using a snapshot. + +B<Note> I am open to changing this to remove the weak-reference magic and +instead require someone to call C<< $context->release >> or similar when they +are done with a context, but that seems more likely to result in rougue +contexts... This method would also require its own form of reference counting.. +This decision will need to be made before we go stable. + +=head2 GENERATING EVENTS + +All event objects should use L<Test::Stream::Event> which will set them up as a +proper event object, as well as add a method to L<Test::Stream::Context> which +is a shortcut for generating that event type. As such you can fire off an event +directly from your context object using the lowercase name of the event class. + + my $ctx = context; + $ctx->ok(1, "pass"); + $ctx->ok(0, "fail, ["This test failed, here is some diag ..."]); + $ctx->note("I am a teapot"); + +All events take a context, and 2 other arguments as the first 3 arguments of +their constructor, these shortcut methods handle those first 3 arguments for +you, making life much easier. + +The other arguments are: + +=over 4 + +=item created + +Should be an arrayref with caller information for where the event was generated. + +=item in_subtest + +True if the event belongs in a subtest, false otherwise. + +=back + +=head1 EVENT OBJECTS + +Here are the primary/public events. There are other events, but they are used +internally. + +=over 4 + +=item L<Test::Stream::Event> + +This is just a base-class, you do not use it directly. + +=item L<Test::Stream::Event::Diag> + +=item L<Test::Stream::Event::Note> + +=item L<Test::Stream::Event::Plan> + +=item L<Test::Stream::Event::Bail> + +These are faily simple and obvious event types. + +=item L<Test::Stream::Event::Ok> + +=item L<Test::Stream::Event::Subtest> + +B<Note:> C<Subtest> is a subclass of C<Ok>. + +Ok can contain diag objects related to that specific ok. Subtest contains all +the events that went into the final subtest result. + +=back + +All events have a context in which they were created, which includes the file +and line number where errors should be reported. They also have details on +where/how they were generated. All other details are event specific. + +The subclass event should never be generated on its own. In fact, just use the +subtest helpers provided by Test::More, or Test::Stream::Context. Under the +hood a Child event is started which adds a subtest to a stack in Test::Stream, +all events then get intercepted by that subtest. When the subtest is done you +issue another Child event to close it out. Once closed a Subtest event will be +generated for you and sent to the stream. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm b/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm new file mode 100644 index 0000000000..1be55694f0 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm @@ -0,0 +1,371 @@ +package Test::Stream::ArrayBase; +use strict; +use warnings; + +use Test::Stream::ArrayBase::Meta; +use Test::Stream::Carp qw/confess croak/; +use Scalar::Util qw/blessed reftype/; + +use Test::Stream::Exporter(); + +sub import { + my $class = shift; + my $caller = caller; + + $class->apply_to($caller, @_); +} + +sub apply_to { + my $class = shift; + my ($caller, %args) = @_; + + # Make the calling class an exporter. + my $exp_meta = Test::Stream::Exporter::Meta->new($caller); + Test::Stream::Exporter->export_to($caller, 'import') + unless $args{no_import}; + + my $ab_meta = Test::Stream::ArrayBase::Meta->new($caller); + + my $ISA = do { no strict 'refs'; \@{"$caller\::ISA"} }; + + if ($args{base}) { + my ($base) = grep { $_->isa($class) } @$ISA; + + croak "$caller is already a subclass of '$base', cannot subclass $args{base}" + if $base; + + my $file = $args{base}; + $file =~ s{::}{/}g; + $file .= ".pm"; + require $file unless $INC{$file}; + + my $pmeta = Test::Stream::ArrayBase::Meta->get($args{base}); + croak "Base class '$args{base}' is not a subclass of $class!" + unless $pmeta; + + push @$ISA => $args{base}; + + $ab_meta->subclass($args{base}); + } + elsif( !grep { $_->isa($class) } @$ISA) { + push @$ISA => $class; + $ab_meta->baseclass(); + } + + $ab_meta->add_accessors(@{$args{accessors}}) + if $args{accessors}; +} + +sub new { + my $class = shift; + my $self = bless [@_], $class; + $self->init if $self->can('init'); + return $self; +} + +sub new_from_pairs { + my $class = shift; + my %params = @_; + my $self = bless [], $class; + + while (my ($k, $v) = each %params) { + my $const = uc($k); + croak "$class has no accessor named '$k'" unless $class->can($const); + my $id = $class->$const; + $self->[$id] = $v; + } + + $self->init if $self->can('init'); + return $self; +} + +sub to_hash { + my $array_obj = shift; + my $meta = Test::Stream::ArrayBase::Meta->get(blessed $array_obj); + my $fields = $meta->fields; + my %out; + for my $f (keys %$fields) { + my $i = $fields->{$f}; + my $val = $array_obj->[$i]; + my $ao = blessed($val) && $val->isa(__PACKAGE__); + $out{$f} = $ao ? $val->to_hash : $val; + } + return \%out; +}; + +1; + +__END__ + +=head1 NAME + +Test::Stream::ArrayBase - Base class for classes that use an arrayref instead +of a hash. + +=head1 SYNOPSYS + +A class: + + package My::Class; + use strict; + use warnings; + + use Test::Stream::ArrayBase accessors => [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; + use Test::Stream::ArrayBase base => 'My::Class', # subclass + accessors => ['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; + + my $one = 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'); + $one->set_bar('A Bar'); + $one->set_baz('A Baz'); + + # It is an arrayref, you can do this! + my ($foo, $bar, $baz) = @$one; + + # import constants: + use My::Class qw/FOO BAR BAZ/; + + $one->[FOO] = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on arrays instead of hashes. The +primary motivation for this is performance (not premature!). Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the index into the array for that accessor. Single inheritence is also +supported. For obvious reasons you cannot use multiple inheritence with an +array based object. + +=head1 METHODS + +=head2 PROVIDED BY ARRAY BASE + +=over 4 + +=item $it = $class->new(@VALUES) + +Create a new instance from a list of ordered values. + +=item $it = $class->new_from_pairs(%ACCESSOR_VAL_PAIRS) + +Create a new instance using key/value pairs. + +=item $hr = $it->to_hash() + +Get a hashref dump of the object. This will also dump any ArrayBase objects +within to a hash, but only surface-depth ones. + +=item $it->import() + +This import method is actually provided by L<Test::Stream::Exporter> and allows +you to import the constants generated for you. + +=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. + +=back + +=head1 ACCESSORS + +To generate accessors you list them when using the module: + + use Test::Stream::ArrayBase accessors => [qw/foo/]; + +This will generate the following subs in your namespace: + +=over 4 + +=item import() + +This will let you import the constants + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returs the field C<foo>'s index into the class arrayref. This +function is also exported, but only when requested. Subclasses will also get +this function as a constant, not simply a method, that means it is copied into +the subclass namespace. + +=back + +=head1 SUBCLASSING + +You can subclass an existing ArrayBase class. + + use Test::Stream::ArrayBase + base => 'Another::ArrayBase::Class', + accessors => [qw/foo bar baz/], + +Once an ArrayBase class is used as a subclass it is locked and no new fields +can be added. All fields in any subclass will start at the next index after the +last field of the parent. All constants from base classes are added to +subclasses automatically. + +=head1 WHY? + +Switching to an arrayref base has resulted in significant performance boosts. + +When Test::Builder was initially refactored to support events, it was slow +beyond reason. A large part of the slowdown was due to the use of proper +methods instead of directly accessing elements. We also switched to using a LOT +more objects that have methods. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm new file mode 100644 index 0000000000..a283afd550 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm @@ -0,0 +1,282 @@ +package Test::Stream::ArrayBase::Meta; +use strict; +use warnings; + +use Test::Stream::Carp qw/confess/; + +my %META; + +sub package { shift->{package} } +sub parent { shift->{parent} } +sub locked { shift->{locked} } +sub fields {({ %{shift->{fields}} })} + +sub new { + my $class = shift; + my ($pkg) = @_; + + $META{$pkg} ||= bless { + package => $pkg, + locked => 0, + }, $class; + + return $META{$pkg}; +} + +sub get { + my $class = shift; + my ($pkg) = @_; + + return $META{$pkg}; +} + +sub baseclass { + my $self = shift; + $self->{parent} = 'Test::Stream::ArrayBase'; + $self->{index} = 0; + $self->{fields} = {}; +} + +sub subclass { + my $self = shift; + my ($parent) = @_; + confess "Already a subclass of $self->{parent}! Tried to sublcass $parent" if $self->{parent}; + + my $pmeta = $self->get($parent) || die "$parent is not an ArrayBase object!"; + $pmeta->{locked} = 1; + + $self->{parent} = $parent; + $self->{index} = $pmeta->{index}; + $self->{fields} = $pmeta->fields; #Makes a copy + + my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package}); + + # Put parent constants into the subclass + for my $field (keys %{$self->{fields}}) { + my $const = uc $field; + no strict 'refs'; + *{"$self->{package}\::$const"} = $parent->can($const) || confess "Could not find constant '$const'!"; + $ex_meta->add($const); + } +} + +my $IDX = -1; +my (@CONST, @GET, @SET); +_GROW(20); + +sub _GROW { + my ($max) = @_; + return if $max <= $IDX; + for (($IDX + 1) .. $max) { + # Var per sub for inlining/constant stuff. + my $c = $_; + my $gi = $_; + my $si = $_; + + $CONST[$_] = sub() { $c }; + $GET[$_] = sub { $_[0]->[$gi] }; + $SET[$_] = sub { $_[0]->[$si] = $_[1] }; + } + $IDX = $max; +} + +*add_accessor = \&add_accessors; +sub add_accessors { + my $self = shift; + + confess "Cannot add accessor, metadata is locked due to a subclass being initialized ($self->{parent}).\n" + if $self->{locked}; + + my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package}); + + for my $name (@_) { + confess "field '$name' already defined!" + if exists $self->{fields}->{$name}; + + my $idx = $self->{index}++; + $self->{fields}->{$name} = $idx; + + _GROW($IDX + 10) if $idx > $IDX; + + my $const = uc $name; + my $gname = lc $name; + my $sname = "set_$gname"; + + { + no strict 'refs'; + *{"$self->{package}\::$const"} = $CONST[$idx]; + *{"$self->{package}\::$gname"} = $GET[$idx]; + *{"$self->{package}\::$sname"} = $SET[$idx]; + } + + $ex_meta->{exports}->{$const} = $CONST[$idx]; + push @{$ex_meta->{polist}} => $const; + } +} + + +1; + +__END__ + +=head1 NAME + +Test::Stream::ArrayBase::Meta - Meta Object for ArrayBase objects. + +=head1 SYNOPSYS + +B<Note:> You probably do not want to directly use this object. + + my $meta = Test::Stream::ArrayBase::Meta->new('Some::Class'); + $meta->add_accessor('foo'); + +=head1 DESCRIPTION + +This is the meta-object used by L<Test::Stream::ArrayBase> + +=head1 METHODS + +=over 4 + +=item $meta = $class->new($package) + +Create a new meta object for the specified class. If one already exists that +instance is returned. + +=item $meta = $class->get($package) + +Get the meta object for the specified class. Returns C<undef> if there is none +initiated. + +=item $package = $meta->package + +Get the package the meta-object manages. + +=item $package = $meta->parent + +Get the parent package to the one being managed. + +=item $bool = $meta->locked + +True if the package has been locked. Locked means no new accessors can be +added. A package is locked once something else subclasses it. + +=item $hr = $meta->fields + +Get a hashref defining the fields on the package. This is primarily for +internal use, it is not very useful outside. + +=item $meta->baseclass + +Make the package inherit from ArrayBase directly. + +=item $meta->subclass($package) + +Set C<$package> as the base class of the managed package. + +=item $meta->add_accessor($name) + +Add an accessor to the package. Also defines the C<"set_$name"> method, and the +C<uc($name)> constant. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Carp.pm b/cpan/Test-Simple/lib/Test/Stream/Carp.pm new file mode 100644 index 0000000000..36a5ee8232 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Carp.pm @@ -0,0 +1,142 @@ +package Test::Stream::Carp; +use strict; +use warnings; + +use Test::Stream::Exporter; + +export croak => sub { require Carp; goto &Carp::croak }; +export confess => sub { require Carp; goto &Carp::confess }; +export cluck => sub { require Carp; goto &Carp::cluck }; +export carp => sub { require Carp; goto &Carp::carp }; + +Test::Stream::Exporter->cleanup; + +1; + +__END__ + +=head1 NAME + +Test::Stream::Carp - Delayed Carp loader. + +=head1 DESCRIPTION + +Use this package instead of L<Carp> to avoid loading L<Carp> until absolutely +necessary. This is used instead of Carp in L<Test::Stream> in order to avoid +loading modules that packages you test may need to load themselves. + +=head1 SUPPORTED EXPORTS + +See L<Carp> for details on each of these functions. + +=over 4 + +=item croak + +=item confess + +=item cluck + +=item carp + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Context.pm b/cpan/Test-Simple/lib/Test/Stream/Context.pm new file mode 100644 index 0000000000..db36fc3497 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Context.pm @@ -0,0 +1,635 @@ +package Test::Stream::Context; +use strict; +use warnings; + +use Scalar::Util qw/blessed weaken/; + +use Test::Stream::Carp qw/confess/; + +use Test::Stream '-internal'; +use Test::Stream::Threads; +use Test::Stream::Event(); +use Test::Stream::Util qw/try translate_filename/; +use Test::Stream::Meta qw/init_tester is_tester/; + +use Test::Stream::ArrayBase( + accessors => [qw/frame stream encoding in_todo todo modern pid skip diag_todo provider monkeypatch_stash/], +); + +use Test::Stream::Exporter qw/import export_to default_exports/; +default_exports qw/context/; +Test::Stream::Exporter->cleanup(); + +{ + no warnings 'once'; + $Test::Builder::Level ||= 1; +} + +my $CURRENT; + +sub init { + $_[0]->[FRAME] ||= _find_context(1); # +1 for call to init + $_[0]->[STREAM] ||= Test::Stream->shared; + $_[0]->[ENCODING] ||= 'legacy'; + $_[0]->[PID] ||= $$; +} + +sub peek { $CURRENT } +sub clear { $CURRENT = undef } + +sub set { + $CURRENT = pop; + weaken($CURRENT); +} + +my $WARNED; +sub context { + my ($level, $stream) = @_; + # If the context has already been initialized we simply return it, we + # ignore any additional parameters as they no longer matter. The first + # thing to ask for a context wins, anything context aware that is called + # later MUST expect that it can get a context found by something down the + # stack. + if ($CURRENT) { + return $CURRENT unless $stream; + return $CURRENT if $stream == $CURRENT->[STREAM]; + } + + my $call = _find_context($level); + $call = _find_context_harder() unless $call; + my $pkg = $call->[0]; + + my $meta = is_tester($pkg) || _find_tester(); + + # Check if $TODO is set in the package, if not check if Test::Builder is + # loaded, and if so if it has Todo set. We check the element directly for + # performance. + my ($todo, $in_todo); + { + my $todo_pkg = $meta->[Test::Stream::Meta::PACKAGE]; + no strict 'refs'; + no warnings 'once'; + if ($todo = $meta->[Test::Stream::Meta::TODO]) { + $in_todo = 1; + } + elsif ($todo = ${"$todo_pkg\::TODO"}) { + $in_todo = 1; + } + elsif ($Test::Builder::Test && defined $Test::Builder::Test->{Todo}) { + $todo = $Test::Builder::Test->{Todo}; + $in_todo = 1; + } + else { + $in_todo = 0; + } + }; + + my ($ppkg, $pname); + if(my @provider = caller(1)) { + ($ppkg, $pname) = ($provider[3] =~ m/^(.*)::([^:]+)$/); + } + + # Uh-Oh! someone has replaced the singleton, that means they probably want + # everything to go through them... We can't do a whole lot about that, but + # we will use the singletons stream which should catch most use-cases. + if ($Test::Builder::_ORIG_Test && $Test::Builder::_ORIG_Test != $Test::Builder::Test) { + $stream ||= $Test::Builder::Test->{stream}; + + my $warn = $meta->[Test::Stream::Meta::MODERN] + && !$WARNED++; + + warn <<" EOT" if $warn; + + ******************************************************************************* + Something replaced the singleton \$Test::Builder::Test. + + The Test::Builder singleton is no longer the central place for all test + events. Please look at Test::Stream, and Test::Stream->intercept() to + accomplish the type of thing that was once done with the singleton. + + All attempts have been made to preserve compatability with older modules, + but if you experience broken behavior you may need to update your code. If + updating your code is not an option you will need to downgrade to a + Test::More prior to version 1.301001. Patches that restore compatability + without breaking necessary Test::Stream functionality will be gladly + accepted. + ******************************************************************************* + EOT + } + + $stream ||= $meta->[Test::Stream::Meta::STREAM] || Test::Stream->shared || confess "No Stream!?"; + if ((USE_THREADS || $stream->_use_fork) && ($stream->pid == $$ && $stream->tid == get_tid())) { + $stream->fork_cull(); + } + + my $encoding = $meta->[Test::Stream::Meta::ENCODING] || 'legacy'; + $call->[1] = translate_filename($encoding => $call->[1]) if $encoding ne 'legacy'; + + my $ctx = bless( + [ + $call, + $stream, + $encoding, + $in_todo, + $todo, + $meta->[Test::Stream::Meta::MODERN] || 0, + $$, + undef, + $in_todo, + [$ppkg, $pname] + ], + __PACKAGE__ + ); + + weaken($ctx->[STREAM]); + + return $ctx if $CURRENT; + + $CURRENT = $ctx; + weaken($CURRENT); + return $ctx; +} + +sub _find_context { + my ($add) = @_; + + $add ||= 0; + my $tb = $Test::Builder::Level - 1; + + # 0 - call to find_context + # 1 - call to context/new + # 2 - call to tool + my $level = 2 + $add + $tb; + my ($package, $file, $line, $subname) = caller($level); + + return unless $package; + + while ($package eq 'Test::Builder') { + ($package, $file, $line, $subname) = caller(++$level); + } + + return unless $package; + + return [$package, $file, $line, $subname]; +} + +sub _find_context_harder { + my $level = 0; + my $fallback; + while(1) { + my ($pkg, $file, $line, $subname) = caller($level++); + $fallback ||= [$pkg, $file, $line, $subname] if $subname =~ m/::END$/; + next if $pkg =~ m/^Test::(Stream|Builder|More|Simple)(::.*)?$/; + return [$pkg, $file, $line, $subname]; + } + + return $fallback if $fallback; + return [ '<UNKNOWN>', '<UNKNOWN>', 0, '<UNKNOWN>' ]; +} + +sub _find_tester { + my $level = 2; + while(1) { + my $pkg = caller($level++); + last unless $pkg; + my $meta = is_tester($pkg) || next; + return $meta; + } + + # find a .t file! + $level = 0; + while(1) { + my ($pkg, $file) = caller($level++); + last unless $pkg; + if ($file eq $0 && $file =~ m/\.t$/) { + return init_tester($pkg); + } + } + + return init_tester('main'); +} + +sub alert { + my $self = shift; + my ($msg) = @_; + + my @call = $self->call; + + warn "$msg at $call[1] line $call[2].\n"; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + + my @call = $self->call; + + $CURRENT = undef if $CURRENT = $self; + + die "$msg at $call[1] line $call[2].\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] } + +sub snapshot { + return bless [@{$_[0]}], blessed($_[0]); +} + +sub send { + my $self = shift; + $self->[STREAM]->send(@_); +} + +# Uhg.. support legacy monkeypatching +# If this is still here in 2020 I will be a sad panda. +{ + sub ok { + return _ok(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{ok} != \&Test::Builder::ok; + my $self = shift; + local $Test::Builder::CTX = $self; + my ($bool, $name, @stash) = @_; + push @{$self->[MONKEYPATCH_STASH]} => \@stash; + my $out = Test::Builder->new->ok($bool, $name); + return $out; + } + + sub _unwind_ok { + my $self = shift; + my ($bool, $name) = @_; + my $stash = pop @{$self->[MONKEYPATCH_STASH]}; + return $self->_ok($bool, $name, @$stash); + } + + sub note { + return _note(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{note} != \&Test::Builder::note; + local $Test::Builder::CTX = shift; + my $out = Test::Builder->new->note(@_); + return $out; + } + + sub diag { + return _diag(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{diag} != \&Test::Builder::diag; + local $Test::Builder::CTX = shift; + my $out = Test::Builder->new->diag(@_); + return $out; + } + + sub plan { + return _plan(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{plan} != \&Test::Builder::plan; + local $Test::Builder::CTX = shift; + my ($num, $dir, $arg) = @_; + $dir ||= 'tests'; + $dir = 'skip_all' if $dir eq 'SKIP'; + $dir = 'no_plan' if $dir eq 'NO PLAN'; + my $out = Test::Builder->new->plan($dir, $num || $arg || ()); + return $out; + } + + sub done_testing { + return $_[0]->stream->done_testing(@_) + unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{done_testing} != \&Test::Builder::done_testing; + + local $Test::Builder::CTX = shift; + my $out = Test::Builder->new->done_testing(@_); + return $out; + } +} + +my %EVENTS; +sub events { \%EVENTS } + +sub register_event { + my $class = shift; + my ($pkg, $name) = @_; + + my $real_name = lc($pkg); + $real_name =~ s/^.*:://g; + + $name ||= $real_name; + + confess "Method '$name' is already defined, event '$pkg' cannot get a context method!" + if $class->can($name); + + $EVENTS{$real_name} = $pkg; + + # Use a string eval so that we get a names sub instead of __ANON__ + local ($@, $!); + eval qq| + sub $name { + my \$self = shift; + my \@call = caller(0); + my \$encoding = \$self->[ENCODING]; + \$call[1] = translate_filename(\$encoding => \$call[1]) if \$encoding ne 'legacy'; + my \$e = '$pkg'->new(\$self->snapshot, [\@call[0 .. 4]], 0, \@_); + return \$self->stream->send(\$e); + }; + 1; + | || die $@; +} + +sub hide_todo { + my $self = shift; + no strict 'refs'; + no warnings 'once'; + + my $pkg = $self->[FRAME]->[0]; + my $meta = is_tester($pkg); + + my $found = { + TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef, + META => $meta->[Test::Stream::Meta::TODO], + PKG => ${"$pkg\::TODO"}, + }; + + $Test::Builder::Test->{Todo} = undef; + $meta->[Test::Stream::Meta::TODO] = undef; + ${"$pkg\::TODO"} = undef; + + return $found; +} + +sub restore_todo { + my $self = shift; + my ($found) = @_; + no strict 'refs'; + no warnings 'once'; + + my $pkg = $self->[FRAME]->[0]; + my $meta = is_tester($pkg); + + $Test::Builder::Test->{Todo} = $found->{TB}; + $meta->[Test::Stream::Meta::TODO] = $found->{META}; + ${"$pkg\::TODO"} = $found->{PKG}; + + my $found2 = { + TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef, + META => $meta->[Test::Stream::Meta::TODO] || undef, + PKG => ${"$pkg\::TODO"} || undef, + }; + + for my $k (qw/TB META PKG/) { + no warnings 'uninitialized'; + next if "$found->{$k}" eq "$found2->{$k}"; + die "Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n" + } + + return; +} + +sub DESTROY { 1 } + +our $AUTOLOAD; +sub AUTOLOAD { + my $class = blessed($_[0]) || $_[0] || confess $AUTOLOAD; + + my $name = $AUTOLOAD; + $name =~ s/^.*:://g; + + my $module = 'Test/Stream/Event/' . ucfirst(lc($name)) . '.pm'; + try { require $module }; + + my $sub = $class->can($name); + goto &$sub if $sub; + + my ($pkg, $file, $line) = caller; + + die qq{Can't locate object method "$name" via package "$class" at $file line $line.\n}; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Context - Object to represent a testing context. + +=head1 DESCRIPTION + +In testing it is important to have context. It is not helpful to simply say a +test failed, you want to know where it failed. This object is responsible for +tracking the context of each test that is run. It makes it possible to get the +file and line number where the failure occured .This object is also responsible +for generating almost all the events you will encounter. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + + sub my_tool { + my $ctx = context(); + + # Generate an event. + $ctx->ok(1, "Pass!"); + } + + 1; + +=head1 EXPORTS + +=over 4 + +=item $ctx = context() + +This function is used to obtain a context. If there is already a context object +in scope this will return it, otherwise it will return a new one. + +It is important that you never store a context object in a variable from a +higher scope, a package variable, or an object attribute. The scope of a +context matters a lot. + +If you want to store a context for later reference use the C<snapshot()> method +to get a clone of it that is safe to store anywhere. + +=back + +=head1 METHODS + +=over 4 + +=item $ctx->alert($MESSAGE) + +This issues a warning at the calling context (filename and line number where +errors should be reported). + +=item $ctx->throw($MESSAGE) + +This throws an exception at the calling context (filename and line number where +errors should be reported). + +=item ($package, $file, $line, $subname) = $ctx->call() + +Get the caller details for the context. This is where errors should be +reported. + +=item $pkg = $ctx->package + +Get the context package. + +=item $file = $ctx->file + +Get the context filename. + +=item $line = $ctx->line + +Get the context line number. + +=item $subname = $ctx->subname + +Get the context subroutine name. + +=item $ctx_copy = $ctx->snapshot + +Get a copy of the context object that is safe to store for later reference. + +=item $ctx->send($event) + +Send an event to the correct L<Test::Stream> object. + +=item $ctx = $class->peek + +Get the current context object, if there is one. + +=back + +=head2 DANGEROUS ONES + +=over 4 + +=item $ctx->set + +=item $cclass->set($ctx) + +Set the context object as the current one, replacing any that might already be +current. + +=item $class->clear + +Unset the current context. + +=item $ctx->register_event($package) + +=item $ctx->register_event($package, $name) + +Register a new event type, creating the shortcut method to generate it. If +C<$name> is not provided it will be taken from the end of the package name, and +will be lowercased. + +=item $hr = $ctx->events + +Get the hashref that holds C<< (name => $package) >> pairs. This is the actual +ref used by the package, so please do not alter it. + +=item $stash = $ctx->hide_todo + +=item $ctx->restore_todo($stash) + +These are used to temporarily hide the TODO value in ALL places where it might +be found. The returned C<$stash> must be used to restore it later. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Event.pm new file mode 100644 index 0000000000..0e35225589 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event.pm @@ -0,0 +1,400 @@ +package Test::Stream::Event; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; +use Test::Stream::Carp qw/confess/; + +use Test::Stream::ArrayBase( + accessors => [qw/context created in_subtest/], + no_import => 1, +); + +sub import { + my $class = shift; + + # Import should only when event is imported, subclasses do not use this + # import. + return if $class ne __PACKAGE__; + + my $caller = caller; + my (%args) = @_; + + my $ctx_meth = delete $args{ctx_method}; + + require Test::Stream::Context; + require Test::Stream; + + # %args may override base + Test::Stream::ArrayBase->apply_to($caller, base => $class, %args); + Test::Stream::Context->register_event($caller, $ctx_meth); + Test::Stream::Exporter::export_to( + 'Test::Stream', + $caller, + qw/OUT_STD OUT_ERR OUT_TODO/, + ); +} + +sub init { + confess("No context provided!") unless $_[0]->[CONTEXT]; +} + +sub encoding { $_[0]->[CONTEXT]->encoding } + +sub extra_details {} + +sub summary { + my $self = shift; + my $type = blessed $self; + $type =~ s/^.*:://g; + + my $ctx = $self->context; + + my ($package, $file, $line) = $ctx->call; + my ($tool_pkg, $tool_name) = @{$ctx->provider}; + $tool_name =~ s/^\Q$tool_pkg\E:://; + + return ( + type => lc($type), + + $self->extra_details(), + + package => $package || undef, + file => $file, + line => $line, + + tool_package => $tool_pkg, + tool_name => $tool_name, + + encoding => $ctx->encoding || undef, + in_todo => $ctx->in_todo || 0, + todo => $ctx->todo || '', + pid => $ctx->pid || 0, + skip => $ctx->skip || '', + ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event - Base class for events + +=head1 DESCRIPTION + +Base class for all event objects that get passed through +L<Test::Stream>. + +=head1 SYNOPSYS + + package Test::Stream::Event::MyEvent; + use strict; + use warnings; + + # This will make our class an event subclass, add the specified accessors, + # inject a helper method into the context objects, and add constants for + # all our fields, and fields we inherit. + use Test::Stream::Event( + accessors => [qw/foo bar baz/], + ctx_method => 'my_event', + ); + + # Chance to initialize some defaults + sub init { + my $self = shift; + # no other args in @_ + + $self->SUPER::init(); + + $self->set_foo('xxx') unless defined $self->foo; + + # Events are arrayrefs, all accessors have a constant defined with + # their index. + $self->[BAR] ||= ""; + + ... + } + + # If your event produces TAP output it must define this method + sub to_tap { + my $self = shift; + return ( + # Constants are defined at import, all are optional, and may appear + # any number of times. + [OUT_STD, $self->foo], + [OUT_ERR, $self->bar], + [OUT_STD, $self->baz], + ); + } + + # This is your hook to add details to the summary fields. + sub extra_details { + my $self = shift; + + my @super_details = $self->SUPER::extra_details(); + + return ( + @super_details, + + foo => $self->foo || undef, + bar => $self->bar || '', + ... + ); + } + + 1; + +=head1 IMPORTING + +=head2 ARGUMENTS + +In addition to the arguments listed here, you may pass in any arguments +accepted by L<Test::Stream::ArrayBase>. + +=over 4 + +=item ctx_method => $NAME + +This specifies the name of the helper meth that will be injected into +L<Test::Stream::Context> to help generate your events. If this is not specified +it will use the lowercased last section of your package name. + +=item base => $BASE_CLASS + +This lets you specify an event class to subclass. B<THIS MUST BE AN EVENT +CLASS>. If you do not specify anything here then C<Test::Stream::Event> will be +used. + +=item accessors => \@FIELDS + +This lets you define any fields you wish to be present in your class. This is +the only way to define storage for your event. Each field specified will get a +read-only accessor with the same name as the field, as well as a setter +C<set_FIELD()>. You will also get a constant that returns the index of the +field in the classes arrayref. The constant is the name of the field in all +upper-case. + +=back + +=head2 SUBCLASSING + +C<Test::Stream::Event> is added to your @INC for you, unless you specify an +alternative base class, which must itself subclass C<Test::Stream::Event>. + +Events B<CAN NOT> use multiple inheritance in most cases. This is mainly +because events are arrayrefs and not hashrefs. Each subclass must add fields as +new indexes after the last index of the parent class. + +=head2 CONTEXT HELPER + +All events need some initial fields for construction. These fields include a +context, and some other state from construction time. The context object will +get helper methods for all events that fill in these fields for you. It is not +advised to ever construct an event object yourself, you should I<always> use +the context helper method. + +=head1 EVENTS ARE ARRAY REFERENCES + +Events are an arrayref. Events use L<Test::Stream::ArrayBase> under the hood to +generate accessors, constants, and field indexes. The key thing to take away +from this is that you cannot add attributes on the fly, you B<MUST> use +L<Test::Stream::Event> and/or L<Test::Stream::ArrayBase> to add fields. + +If you need a place to store extar generic, and possibly unpredictable, data, +you should add a field and assign a hashref to it, then use that hashref to +store your mixed data. + +=head1 METHODS + +=over 4 + +=item $ctx = $e->context + +Get a snapshot of the context as it was when this event was generated + +=item $call = $e->created + +Get the C<caller()> details from when the objects was created. This is usually +the call to the tool that generated the event such as C<Test::More::ok()>. + +=item $bool = $e->in_subtest + +Check if the event was generated within a subtest. + +=item $encoding = $e->encoding + +Get the encoding that was in effect when the event was generated + +=item @details = $e->extra_details + +Get an ordered key/value pair list of summary fields for the event. Override +this to add additional fields. + +=item @summary = $e->summary + +Get an ordered key/value pair list of summary fields for the event, including +parent class fields. In general you should not override this as it has a useful +(thought not depended upon) order. + +=back + +=head1 SUMMARY FIELDS + +These are the fields that will be present when calling +C<< my %sum = $e->summary >>. Please note that the fields are returned as an +order key+pair list, they can be directly assigned to a hash if desired, or +they can be assigned to an array to preserver the order. The order is as it +appears below, B<NOT> alphabetical. + +=over 4 + +=item type + +The name of the event type, typically this is the lowercase form of the last +part of the class name. + +=item package + +The package that generated this event. + +=item file + +The file in which the event was generated, and to which errors should be attributed. + +=item line + +The line number on which the event was generated, and to which errors should be +attributed. + +=item tool_package + +The package that provided the tool that generated the event (example: +Test::More) + +=item tool_name + +The name of the sub that produced the event (examples: C<ok()>, C<is()>). + +=item encoding + +The encoding that should be used when printing the TAP output from this event. + +=item in_todo + +True if the event was generated while TODO was in effect. + +=item todo + +The todo message if the event was generated with TODO in effect. + +=item pid + +The PID in which the event was generated. + +=item skip + +The skip message if the event was generated via skip. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm new file mode 100644 index 0000000000..4164d55359 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm @@ -0,0 +1,182 @@ +package Test::Stream::Event::Bail; +use strict; +use warnings; + +use Test::Stream::Event( + accessors => [qw/reason quiet/], +); + +sub to_tap { + my $self = shift; + return if $self->[QUIET]; + return [ + OUT_STD, + "Bail out! " . $self->reason . "\n", + ]; +} + +sub extra_details { + my $self = shift; + return ( + $self->reason || '', + $self->quiet || 0, + ); +} + + +1; + +__END__ + +=head1 NAME + +Test::Stream::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 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Bail; + + my $ctx = context(); + my $event = $ctx->bail('Stuff is broken'); + +=head1 METHODS + +Inherits from L<Test::Stream::Event>. Also defines: + +=over 4 + +=item $reason = $e->reason + +The reason for the bailout. + +=item $bool = quiet + +Should the bailout be quiet? + +=back + +=head1 SUMMARY FIELDS + +These are the fields that will be present when calling +C<< my %sum = $e->summary >>. Please note that the fields are returned as an +order key+pair list, they can be directly assigned to a hash if desired, or +they can be assigned to an array to preserver the order. The order is as it +appears below, B<NOT> alphabetical. + +=over 4 + +=item reason + +Reason for the bailout + +=item quiet + +Boolean, true if the bailout should be quiet. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Child.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Child.pm new file mode 100644 index 0000000000..d6d380780e --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Child.pm @@ -0,0 +1,144 @@ +package Test::Stream::Event::Child; +use strict; +use warnings; + +use Test::Stream::Carp qw/confess/; +use Test::Stream::Event( + accessors => [qw/action name no_note/], +); + +sub init { + confess "did not get an action" unless $_[0]->[ACTION]; + confess "action must be either 'push' or 'pop', not '$_[0]->[ACTION]'" + unless $_[0]->[ACTION] =~ m/^(push|pop)$/; + + $_[0]->[NAME] ||= ""; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Child - Child event type + +=head1 DESCRIPTION + +B<YOU PROBABLY DO NOT WANT TO USE THIS YOURSELF> + +Child events are used under the hood to start and stop subtests. +L<Test::Stream::Event::Subtest> events are generated by child events. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Bail; + + my $ctx = context(); + $ctx->child( 'push', $NAME ); + + ... # Generate events + + # Generates a subtest event + $ctx->child( 'pop', $NAME ); + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm new file mode 100644 index 0000000000..696c70d541 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm @@ -0,0 +1,198 @@ +package Test::Stream::Event::Diag; +use strict; +use warnings; + +use Test::Stream::Event( + accessors => [qw/message linked/], + ctx_method => '_diag', +); + +use Test::Stream::Util qw/try/; +use Scalar::Util qw/weaken/; +use Test::Stream::Carp qw/confess/; + +sub init { + $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE]; + weaken($_[0]->[LINKED]) if $_[0]->[LINKED]; +} + +sub link { + my $self = shift; + my ($to) = @_; + confess "Already linked!" if $self->[LINKED]; + $self->[LINKED] = $to; + weaken($self->[LINKED]); +} + +sub to_tap { + my $self = shift; + + chomp(my $msg = $self->[MESSAGE]); + + $msg = "# $msg" unless $msg =~ m/^\n/; + $msg =~ s/\n/\n# /g; + + return [ + ($self->[CONTEXT]->diag_todo ? OUT_TODO : OUT_ERR), + "$msg\n", + ]; +} + +sub extra_details { + my $self = shift; + return ( message => $self->message || '' ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Diag - Diag event type + +=encoding utf8 + +=head1 DESCRIPTION + +Diagnostics messages, typically rendered to STDERR. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Diag; + + my $ctx = context(); + my $event = $ctx->diag($message); + +=head1 ACCESSORS + +=over 4 + +=item $diag->message + +The message for the diag. + +=item $diag->linked + +The Ok event the diag is linked to, if it is. + +=back + +=head1 METHODS + +=over 4 + +=item $diag->link($ok); + +Link the diag to an OK event. + +=back + +=head1 SUMMARY FIELDS + +=over 4 + +=item message + +The message from the diag. + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm new file mode 100644 index 0000000000..2f181a9ee8 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm @@ -0,0 +1,127 @@ +package Test::Stream::Event::Finish; +use strict; +use warnings; + +use Test::Stream::Event( + accessors => [qw/tests_run tests_failed/], +); + +sub extra_details { + my $self = shift; + return ( + tests_run => $self->tests_run || 0, + tests_failed => $self->tests_failed || 0, + ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Finish - The finish event type + +=head1 DESCRIPTION + +Sent after testing is finished. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm new file mode 100644 index 0000000000..91185f098b --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm @@ -0,0 +1,169 @@ +package Test::Stream::Event::Note; +use strict; +use warnings; + +use Test::Stream::Event( + accessors => [qw/message/], + ctx_method => '_note', +); + +use Test::Stream::Carp qw/confess/; + +sub init { + $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE]; +} + +sub to_tap { + my $self = shift; + + chomp(my $msg = $self->[MESSAGE]); + $msg = "# $msg" unless $msg =~ m/^\n/; + $msg =~ s/\n/\n# /g; + + return [OUT_STD, "$msg\n"]; +} + +sub extra_details { + my $self = shift; + return ( message => $self->message || '' ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Note - Note event type + +=encoding utf8 + +=head1 DESCRIPTION + +Notes, typically rendered to STDOUT. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Note; + + my $ctx = context(); + my $event = $ctx->Note($message); + +=head1 ACCESSORS + +=over 4 + +=item $note->message + +The message for the note. + +=back + +=head1 SUMMARY FIELDS + +=over 4 + +=item message + +The message from the note. + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm new file mode 100644 index 0000000000..9b1be21aa5 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm @@ -0,0 +1,386 @@ +package Test::Stream::Event::Ok; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; +use Test::Stream::Util qw/unoverload_str/; +use Test::Stream::Carp qw/confess/; + +use Test::Stream::Event( + accessors => [qw/real_bool name diag bool level/], + ctx_method => '_ok', +); + +sub skip { $_[0]->[CONTEXT]->skip } +sub todo { $_[0]->[CONTEXT]->todo } + +sub init { + my $self = shift; + + # Do not store objects here, only true/false/undef + if ($self->[REAL_BOOL]) { + $self->[REAL_BOOL] = 1; + } + elsif(defined $self->[REAL_BOOL]) { + $self->[REAL_BOOL] = 0; + } + $self->[LEVEL] = $Test::Builder::Level; + + my $ctx = $self->[CONTEXT]; + my $rb = $self->[REAL_BOOL]; + my $todo = $ctx->in_todo; + my $skip = defined $ctx->skip; + my $b = $rb || $todo || $skip || 0; + my $diag = delete $self->[DIAG]; + my $name = $self->[NAME]; + + $self->[BOOL] = $b ? 1 : 0; + + unless ($rb || ($todo && $skip)) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + my $prefix = $ENV{HARNESS_ACTIVE} ? "\n" : ""; + + my ($pkg, $file, $line) = $ctx->call; + + if (defined $name) { + $msg = qq[$prefix $msg test '$name'\n at $file line $line.]; + } + else { + $msg = qq[$prefix $msg test at $file line $line.]; + } + + $self->add_diag($msg); + } + + $self->add_diag(" You named your test '$name'. You shouldn't use numbers for your test names.\n Very confusing.") + if $name && $name =~ m/^[\d\s]+$/; + + $self->add_diag(@$diag) if $diag && @$diag; +} + +sub to_tap { + my $self = shift; + my ($num) = @_; + + my $name = $self->[NAME]; + my $context = $self->[CONTEXT]; + my $skip = $context->skip; + my $todo = $context->todo; + + my @out; + push @out => "not" unless $self->[REAL_BOOL]; + push @out => "ok"; + push @out => $num if defined $num; + + unoverload_str \$name if defined $name; + + if ($name) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + push @out => ("-", $name); + } + + if (defined $skip && defined $todo) { + push @out => "# TODO & SKIP"; + push @out => $todo if length $todo; + } + elsif ($context->in_todo) { + push @out => "# TODO"; + push @out => $todo if length $todo; + } + elsif (defined $skip) { + push @out => "# skip"; + push @out => $skip if length $skip; + } + + my $out = join " " => @out; + $out =~ s/\n/\n# /g; + + return [OUT_STD, "$out\n"] unless $self->[DIAG]; + + return ( + [OUT_STD, "$out\n"], + map {$_->to_tap($num)} @{$self->[DIAG]}, + ); +} + +sub add_diag { + my $self = shift; + + my $context = $self->[CONTEXT]; + my $created = $self->[CREATED]; + + for my $item (@_) { + next unless $item; + + if (ref $item) { + confess("Only diag objects can be linked to events.") + unless blessed($item) && $item->isa('Test::Stream::Event::Diag'); + + $item->link($self); + } + else { + $item = Test::Stream::Event::Diag->new($context, $created, $self->[IN_SUBTEST], $item, $self); + } + + push @{$self->[DIAG]} => $item; + } +} + +{ + # Yes, we do want to override the imported one. + no warnings 'redefine'; + sub clear_diag { + my $self = shift; + return unless $self->[DIAG]; + my $out = $self->[DIAG]; + $self->[DIAG] = undef; + $_->set_linked(undef) for @$out; + return $out; + } +} + +sub to_legacy { + my $self = shift; + + my $result = {}; + $result->{ok} = $self->bool ? 1 : 0; + $result->{actual_ok} = $self->real_bool; + $result->{name} = $self->name; + + my $ctx = $self->context; + + if($self->skip && ($ctx->in_todo || $ctx->todo)) { + $result->{type} = 'todo_skip', + $result->{reason} = $ctx->skip || $ctx->todo; + } + elsif($ctx->in_todo || $ctx->todo) { + $result->{reason} = $ctx->todo; + $result->{type} = 'todo'; + } + elsif($ctx->skip) { + $result->{reason} = $ctx->skip; + $result->{type} = 'skip'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + if ($result->{reason} eq 'incrementing test number') { + $result->{type} = 'unknown'; + } + + return $result; +} + +sub extra_details { + my $self = shift; + + require Test::Stream::Tester::Events; + + my $diag = join "\n", map { + my $msg = $_->message; + chomp($msg); + split /[\n\r]+/, $msg; + } @{$self->diag || []}; + + return ( + diag => $diag || '', + bool => $self->bool || 0, + name => $self->name || undef, + real_bool => $self->real_bool || 0 + ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Ok - Ok event type + +=encoding utf8 + +=head1 DESCRIPTION + +Ok events are generated whenever you run a test that produces a result. +Examples are C<ok()>, and C<is()>. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Ok; + + my $ctx = context(); + my $event = $ctx->ok($bool, $name, \@diag); + +=head1 ACCESSORS + +=over 4 + +=item $rb = $e->real_bool + +This is the true/false value of the test after TODO, SKIP, and similar +modifiers are taken into account. + +=item $name = $e->name + +Name of the test. + +=item $diag = $e->diag + +An arrayref with all the L<Test::Stream::Event::Diag> events reduced down to +just the messages. Some coaxing has beeen done to combine all the messages into +a single string. + +=item $b = $e->bool + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=item $l = $e->level + +For legacy L<Test::Builder> support. Do not use this, it can go away, or change +behavior at any time. + +=back + +=head1 METHODS + +=over 4 + +=item $le = $e->to_legacy + +Returns a hashref that matches some legacy details about ok's. You should +probably not use this for anything new. + +=item $e->add_diag($diag_event, "diag message" ...) + +Add a diag to the event. The diag may be a diag event, or a simple string. + +=item $diag = $e->clear_diag + +Remove all diag events, then return them in an arrayref. + +=back + +=head1 SUMMARY FIELDS + +=over 4 + +=item diag + +A single string with all the messages from the diags linked to the event. + +=item bool + +True/False passed into the test. + +=item name + +Name of the test. + +=item real_bool + +True/False value accounting for TODO and SKIP. + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm new file mode 100644 index 0000000000..84be2a040b --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm @@ -0,0 +1,219 @@ +package Test::Stream::Event::Plan; +use strict; +use warnings; + +use Test::Stream::Event( + accessors => [qw/max directive reason/], + ctx_method => '_plan', +); + +use Test::Stream::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 { + $_[0]->[DIRECTIVE] = ''; + confess "Cannot have a reason without a directive!" + if defined $_[0]->[REASON]; + + confess "No number of tests specified" + unless defined $_[0]->[MAX]; + + + } +} + +sub to_tap { + my $self = shift; + + my $max = $self->[MAX]; + my $directive = $self->[DIRECTIVE]; + my $reason = $self->[REASON]; + + return if $directive && $directive eq 'NO PLAN'; + + my $plan = "1..$max"; + if ($directive) { + $plan .= " # $directive"; + $plan .= " $reason" if defined $reason; + } + + return [OUT_STD, "$plan\n"]; +} + +sub extra_details { + my $self = shift; + return ( + max => $self->max || 0, + directive => $self->directive || undef, + reason => $self->reason || undef + ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Plan - The event of a plan + +=encoding utf8 + +=head1 DESCRIPTION + +Plan events are fired off whenever a plan is declared, done testing is called, +or a subtext completes. + +=head1 SYNOPSYS + + use Test::Stream::Context qw/context/; + use Test::Stream::Event::Plan; + + my $ctx = context(); + my $event = $ctx->plan($max, $directive, $reason); + +=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 SUMMARY FIELDS + +=over 4 + +=item max + +Number of expected tests. + +=item directive + +Directive. + +=item reason + +Reason for directive. + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm new file mode 100644 index 0000000000..ec54743ddf --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm @@ -0,0 +1,273 @@ +package Test::Stream::Event::Subtest; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; +use Test::Stream::Carp qw/confess/; +use Test::Stream qw/-internal STATE_PASSING STATE_COUNT STATE_FAILED STATE_PLAN/; + +use Test::Stream::Event( + base => 'Test::Stream::Event::Ok', + accessors => [qw/state events exception/], +); + +sub init { + my $self = shift; + + $self->[REAL_BOOL] = $self->[STATE]->[STATE_PASSING] && $self->[STATE]->[STATE_COUNT]; + $self->[EVENTS] ||= []; + + if (my $le = $self->[EXCEPTION]) { + my $is_skip = $le->isa('Test::Stream::Event::Plan'); + $is_skip &&= $le->directive; + $is_skip &&= $le->directive eq 'SKIP'; + + if ($is_skip) { + my $skip = $le->reason || "skip all"; + # Should be a snapshot now: + $self->[CONTEXT]->set_skip($skip); + $self->[REAL_BOOL] = 1; + } + } + + push @{$self->[DIAG]} => ' No tests run for subtest.' + unless $self->[EXCEPTION] || $self->[STATE]->[STATE_COUNT]; + + $self->SUPER::init(); +} + +sub to_tap { + my $self = shift; + my ($num, $delayed) = @_; + + unless($delayed) { + return if $self->[EXCEPTION] + && $self->[EXCEPTION]->isa('Test::Stream::Event::Bail'); + + return $self->SUPER::to_tap($num); + } + + # Subtest final result first + $self->[NAME] =~ s/$/ {/mg; + my @out = ( + $self->SUPER::to_tap($num), + $self->_render_events(@_), + [OUT_STD, "}\n"], + ); + $self->[NAME] =~ s/ \{$//mg; + return @out; +} + +sub _render_events { + my $self = shift; + my ($num, $delayed) = @_; + + my $idx = 0; + my @out; + for my $e (@{$self->events}) { + next unless $e->can('to_tap'); + $idx++ if $e->isa('Test::Stream::Event::Ok'); + push @out => $e->to_tap($idx, $delayed); + } + + for my $set (@out) { + $set->[1] =~ s/^/ /mg; + } + + return @out; +} + +sub extra_details { + my $self = shift; + + my @out = $self->SUPER::extra_details(); + my $plan = $self->[STATE]->[STATE_PLAN]; + my $exception = $self->exception; + + return ( + @out, + + events => $self->events || undef, + + exception => $exception || undef, + plan => $plan || undef, + + passing => $self->[STATE]->[STATE_PASSING], + count => $self->[STATE]->[STATE_COUNT], + failed => $self->[STATE]->[STATE_FAILED], + ); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Event::Subtest - Subtest event + +=head1 DESCRIPTION + +This event is used to encapsulate subtests. + +=head1 SYNOPSYS + +B<YOU PROBABLY DO NOT WANT TO DIRECTLY GENERATE A SUBTEST EVENT>. See the +C<subtest()> function from L<Test::More::Tools> instead. + +=head1 INHERITENCE + +the C<Test::Stream::Event::Subtest> class inherits from +L<Test::Stream::Event::Ok> and shares all of its methods and fields. + +=head1 ACCESSORS + +=over 4 + +=item my $se = $e->events + +This returns an arrayref with all events generated during the subtest. + +=item my $x = $e->exception + +If the subtest was killed by a C<skip_all> or C<BAIL_OUT> the event will be +returned by this accessor. + +=back + +=head1 SUMMARY FIELDS + +C<Test::Stream::Event::Subtest> inherits all of the summary fields from +L<Test::Stream::Event::Ok>. + +=over 4 + +=item events => \@subevents + +An arrayref containing all the events generated within the subtest, including +plans. + +=item exception => \$plan_or_bail + +If the subtest was aborted due to a bail-out or a skip_all, the event that +caused the abort will be here (in addition to the events arrayref. + +=item plan => \$plan + +The plan event for the subtest, this may be auto-generated. + +=item passing => $bool + +True if the subtest was passing, false otherwise. This should not be confused +with 'bool' inherited from L<Test::Stream::Event::Ok> which takes TODO into +account. + +=item count => $num + +Number of tests run inside the subtest. + +=item failed => $num + +Number of tests that failed inside the subtest. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm b/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm new file mode 100644 index 0000000000..2294d01360 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm @@ -0,0 +1,259 @@ +package Test::Stream::ExitMagic; +use strict; +use warnings; + +require Test::Stream::ExitMagic::Context; + +use Test::Stream::ArrayBase( + accessors => [qw/pid done/], +); + +sub init { + $_[0]->[PID] = $$; + $_[0]->[DONE] = 0; +} + +sub do_magic { + my $self = shift; + my ($stream, $context) = @_; + return unless $stream; + return if $stream->no_ending && !$context; + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + return unless $self->[PID] == $$; + + # Only run once + return if $self->[DONE]++; + + my $real_exit_code = $?; + + my $plan = $stream->plan; + my $total = $stream->count; + my $fails = $stream->failed; + + $context ||= Test::Stream::ExitMagic::Context->new([caller()], $stream); + $context->finish($total, $fails); + + # Ran tests but never declared a plan or hit done_testing + return $self->no_plan_magic($stream, $context, $total, $fails, $real_exit_code) + if $total && !$plan; + + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + return unless $plan; + + # Don't do an ending if we bailed out. + if( $stream->bailed_out ) { + $stream->is_passing(0); + return; + } + + # Figure out if we passed or failed and print helpful messages. + return $self->be_helpful_magic($stream, $context, $total, $fails, $plan, $real_exit_code) + if $total && $plan; + + if ($plan->directive && $plan->directive eq 'SKIP') { + $? = 0; + return; + } + + if($real_exit_code) { + $context->diag("Looks like your test exited with $real_exit_code before it could output anything.\n"); + $stream->is_passing(0); + $? = $real_exit_code; + return; + } + + unless ($total) { + $context->diag("No tests run!\n"); + $stream->is_passing(0); + $? = 255; + return; + } + + $stream->is_passing(0); + $? = 255; +} + +sub no_plan_magic { + my $self = shift; + my ($stream, $context, $total, $fails, $real_exit_code) = @_; + + $stream->is_passing(0); + $context->diag("Tests were run but no plan was declared and done_testing() was not seen."); + + if($real_exit_code) { + $context->diag("Looks like your test exited with $real_exit_code just after $total.\n"); + $? = $real_exit_code; + return; + } + + # But if the tests ran, handle exit code. + if ($total && $fails) { + my $exit_code = $fails <= 254 ? $fails : 254; + $? = $exit_code; + return; + } + + $? = 254; + return; +} + +sub be_helpful_magic { + my $self = shift; + my ($stream, $context, $total, $fails, $plan, $real_exit_code) = @_; + + my $planned = $plan->max; + my $num_extra = $plan->directive && $plan->directive eq 'NO PLAN' ? 0 : $total - $planned; + + if ($num_extra != 0) { + my $s = $planned == 1 ? '' : 's'; + $context->diag("Looks like you planned $planned test$s but ran $total.\n"); + $stream->is_passing(0); + } + + if($fails) { + my $s = $fails == 1 ? '' : 's'; + my $qualifier = $num_extra == 0 ? '' : ' run'; + $context->diag("Looks like you failed $fails test$s of ${total}${qualifier}.\n"); + $stream->is_passing(0); + } + + if($real_exit_code) { + $context->diag("Looks like your test exited with $real_exit_code just after $total.\n"); + $stream->is_passing(0); + $? = $real_exit_code; + return; + } + + my $exit_code; + if($fails) { + $exit_code = $fails <= 254 ? $fails : 254; + } + elsif($num_extra != 0) { + $exit_code = 255; + } + else { + $exit_code = 0; + } + + $? = $exit_code; + return; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::ExitMagic - Encapsulate the magic exit logic + +=head1 DESCRIPTION + +It's magic! well kinda.. + +=head1 SYNOPSYS + +Don't use this yourself, let L<Test::Stream> handle it. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm b/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm new file mode 100644 index 0000000000..599631e61b --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm @@ -0,0 +1,131 @@ +package Test::Stream::ExitMagic::Context; +use strict; +use warnings; + +use Test::Stream::ArrayBase( + base => 'Test::Stream::Context', +); + +sub init { + $_[0]->[PID] = $$; + $_[0]->[ENCODING] = 'legacy'; +} + +sub snapshot { $_[0] } + +1; + +__END__ + +=head1 NAME + +Test::Stream::ExitMagic::Context - Special context for use in an END block. + +=head1 DESCRIPTION + +L<Test::Stream> needs to accomplish some magic in an END block. In an END block +it is not always possible to have a true/complete context object, so this +trivial one is used instead. + +B<DO NOT USE THIS>. If you find yourself thinking that you should use this then +B<STOP!> because you are very likely to be wrong. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Exporter.pm b/cpan/Test-Simple/lib/Test/Stream/Exporter.pm new file mode 100644 index 0000000000..da0405ee8a --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Exporter.pm @@ -0,0 +1,327 @@ +package Test::Stream::Exporter; +use strict; +use warnings; + +use Test::Stream::PackageUtil; +use Test::Stream::Exporter::Meta; + +sub export; +sub exports; +sub default_export; +sub default_exports; + +# Test::Stream::Carp uses this module. +sub croak { require Carp; goto &Carp::croak } +sub confess { require Carp; goto &Carp::confess } + +BEGIN { Test::Stream::Exporter::Meta->new(__PACKAGE__) }; + +sub import { + my $class = shift; + my $caller = caller; + + Test::Stream::Exporter::Meta->new($caller); + + export_to($class, $caller, @_); +} + +default_exports qw/export exports default_export default_exports/; +exports qw/export_to export_meta export_to_level/; + +default_export import => sub { + my $class = shift; + my $caller = caller; + my @args = @_; + + my $stash = $class->before_import($caller, \@args) if $class->can('before_import'); + export_to($class, $caller, @args); + $class->after_import($caller, $stash, @args) if $class->can('after_import'); +}; + +sub export_meta { + my $pkg = shift || caller; + return Test::Stream::Exporter::Meta->get($pkg); +} + +sub export_to { + my $class = shift; + my ($dest, @imports) = @_; + + my $meta = Test::Stream::Exporter::Meta->get($class) + || confess "$class is not an exporter!?"; + + my (@include, %exclude); + for my $import (@imports) { + if (substr($import, 0, 1) eq '!') { + $import =~ s/^!//g; + $exclude{$import}++; + } + else { + push @include => $import; + } + } + + @include = $meta->default unless @include; + + my $exports = $meta->exports; + for my $name (@include) { + next if $exclude{$name}; + + my $ref = $exports->{$name} + || croak "$class does not export $name"; + + no strict 'refs'; + $name =~ s/^[\$\@\%\&]//; + *{"$dest\::$name"} = $ref; + } +} + +sub export_to_level { + my $class = shift; + my ($level, undef, @want) = @_; + + my $dest = caller($level); + my $export_to = $class->can('export_to') || \&export_to; + + $class->$export_to($dest, @want); +} + +sub cleanup { + my $pkg = caller; + package_purge_sym($pkg, map {(CODE => $_)} qw/export exports default_export default_exports/); +} + +sub export { + my ($name, $ref) = @_; + my $caller = caller; + + my $meta = export_meta($caller) || + confess "$caller is not an exporter!?"; + + $meta->add($name, $ref); +} + +sub exports { + my $caller = caller; + + my $meta = export_meta($caller) || + confess "$caller is not an exporter!?"; + + $meta->add_bulk(@_); +} + +sub default_export { + my ($name, $ref) = @_; + my $caller = caller; + + my $meta = export_meta($caller) || + confess "$caller is not an exporter!?"; + + $meta->add_default($name, $ref); +} + +sub default_exports { + my $caller = caller; + + my $meta = export_meta($caller) || + confess "$caller is not an exporter!?"; + + $meta->add_default_bulk(@_); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Exporter - Declarative exporter for Test::Stream and friends. + +=head1 DESCRIPTION + +Test::Stream::Exporter is an internal implementation of some key features from +L<Exporter::Declare>. This is a much more powerful exporting tool than +L<Exporter>. This package is used to easily manage complicated EXPORT logic +across L<Test::Stream> and friends. + +=head1 SYNOPSYS + + use Test::Stream::Exporter; + + # Export some named subs from the package + default_exports qw/foo bar baz/; + exports qw/fluxx buxx suxx/; + + # Export some anonymous subs under specific names. + export some_tool => sub { ... }; + default_export another_tool => sub { ... }; + + # Call this when you are done providing exports in order to cleanup your + # namespace. + Test::Stream::Exporter->cleanup; + + # Hooks for import() + + # Called before importing symbols listed in $args_ref. This gives you a + # chance to munge the arguments. + sub before_import { + my $class = shift; + my ($caller, $args_ref) = @_; + ... + + return $stash; # For use in after_import, can be anything + } + + # Chance to do something after import() is done + sub after_import { + my $class = shift; + my ($caller, $stash, @args) = @_; + ... + } + +=head1 EXPORTS + +=head2 DEFAULT + +=over 4 + +=item import + +Your class needs this to function as an exporter. + +=item export NAME => sub { ... } + +=item default_export NAME => sub { ... } + +These are used to define exports that may not actually be subs in the current +package. + +=item exports qw/foo bar baz/ + +=item default_exports qw/foo bar baz/ + +These let you export package subs en mass. + +=back + +=head2 AVAILABLE + +=over 4 + +=item export_to($from, $dest, @symbols) + +=item $from->export_to($dest, @symbols) + +Export from the C<$from> package into the C<$dest> package. The class-method +form only works if the method has been imported into the C<$from> package. + +=item $meta = export_meta($package) + +=item $meta = $package->export_meta() + +Get the export meta object from the package. The class method form only works +if the package has imported it. + +=back + +=head1 HOOKS + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm new file mode 100644 index 0000000000..e3de004448 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm @@ -0,0 +1,216 @@ +package Test::Stream::Exporter::Meta; +use strict; +use warnings; + +use Test::Stream::PackageUtil; + +# Test::Stream::Carp uses this module. +sub croak { require Carp; goto &Carp::croak } +sub confess { require Carp; goto &Carp::confess } + +sub exports { $_[0]->{exports} } +sub default { @{$_[0]->{pdlist}} } +sub all { @{$_[0]->{polist}} } + +sub add { + my $self = shift; + my ($name, $ref) = @_; + + confess "Name is mandatory" unless $name; + + confess "$name is already exported" + if $self->exports->{$name}; + + $ref ||= package_sym($self->{package}, CODE => $name); + + confess "No reference or package sub found for '$name' in '$self->{package}'" + unless $ref && ref $ref; + + $self->exports->{$name} = $ref; + push @{$self->{polist}} => $name; +} + +sub add_default { + my $self = shift; + my ($name, $ref) = @_; + + $self->add($name, $ref); + push @{$self->{pdlist}} => $name; + + $self->{default}->{$name} = 1; +} + +sub add_bulk { + my $self = shift; + for my $name (@_) { + confess "$name is already exported" + if $self->exports->{$name}; + + my $ref = package_sym($self->{package}, CODE => $name) + || confess "No reference or package sub found for '$name' in '$self->{package}'"; + + $self->{exports}->{$name} = $ref; + } + + push @{$self->{polist}} => @_; +} + +sub add_default_bulk { + my $self = shift; + + for my $name (@_) { + confess "$name is already exported" + if $self->exports->{$name}; + + my $ref = package_sym($self->{package}, CODE => $name) + || confess "No reference or package sub found for '$name' in '$self->{package}'"; + + $self->{exports}->{$name} = $ref; + $self->{default}->{$name} = 1; + } + + push @{$self->{polist}} => @_; + push @{$self->{pdlist}} => @_; +} + +my %EXPORT_META; + +sub new { + my $class = shift; + my ($pkg) = @_; + + confess "Package is required!" + unless $pkg; + + $EXPORT_META{$pkg} ||= bless({ + exports => {}, + default => {}, + pdlist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT"} }, + polist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT_OK"} }, + package => $pkg, + }, $class); + + return $EXPORT_META{$pkg}; +} + +sub get { + my $class = shift; + my ($pkg) = @_; + + confess "Package is required!" + unless $pkg; + + return $EXPORT_META{$pkg}; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Exporter::Meta - Meta object for exporters. + +=head1 DESCRIPTION + +L<Test::Stream::Exporter> uses this package to manage exports. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/IOSets.pm b/cpan/Test-Simple/lib/Test/Stream/IOSets.pm new file mode 100644 index 0000000000..ae862776fd --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/IOSets.pm @@ -0,0 +1,243 @@ +package Test::Stream::IOSets; +use strict; +use warnings; + +use Test::Stream::Util qw/protect/; + +init_legacy(); + +sub new { + my $class = shift; + my $self = bless {}, $class; + + $self->reset_legacy; + + return $self; +} + +sub init_encoding { + my $self = shift; + my ($name, @handles) = @_; + + unless($self->{$name}) { + my ($out, $fail, $todo); + + if (@handles) { + ($out, $fail, $todo) = @handles; + } + else { + ($out, $fail) = $self->open_handles(); + } + + binmode($out, ":encoding($name)"); + binmode($fail, ":encoding($name)"); + + $self->{$name} = [$out, $fail, $todo || $out]; + } + + return $self->{$name}; +} + +my $LEGACY; +sub hard_reset { $LEGACY = undef } +sub init_legacy { + return if $LEGACY; + + my ($out, $err) = open_handles(); + + _copy_io_layers(\*STDOUT, $out); + _copy_io_layers(\*STDERR, $err); + + _autoflush($out); + _autoflush($err); + + # LEGACY, BAH! + # This is necessary to avoid out of sequence writes to the handles + _autoflush(\*STDOUT); + _autoflush(\*STDERR); + + $LEGACY = [$out, $err, $out]; +} + +sub reset_legacy { + my $self = shift; + init_legacy() unless $LEGACY; + my ($out, $fail, $todo) = @$LEGACY; + $self->{legacy} = [$out, $fail, $todo]; +} + +sub _copy_io_layers { + my($src, $dst) = @_; + + protect { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); + _apply_layers($dst, @src_layers) if @src_layers; + }; + + return; +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; +} + +sub open_handles { + open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; + open( my $err, ">&STDERR" ) or die "Can't dup STDERR: $!"; + + _autoflush($out); + _autoflush($err); + + return ($out, $err); +} + +sub _apply_layers { + my ($fh, @layers) = @_; + my %seen; + my @unique = grep { $_ !~ /^(unix|perlio)$/ && !$seen{$_}++ } @layers; + binmode($fh, join(":", "", "raw", @unique)); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::IOSets - Manage sets of IO Handles in specific encodings. + +=head1 DESCRIPTION + +The module does 2 things, first it emulates the old behavior of +L<Test::Builder> which clones and modifies the STDOUT and STDERR handles. This +legacy behavior can be referenced as C<'legacy'> in place of an encoding. It +also manages multiple clones of the standard file handles which are set to +specific encodings. + +=head1 METHODS + +In general you should not use this module yourself. If you must use it directly +then there is really only 1 method you should use: + +=over 4 + +=item $ar = $ioset->init_encoding($ENCODING) + +=item $ar = $ioset->init_encoding('legacy') + +=item $ar = $ioset->init_encoding($NAME, $STDOUT, $STDERR) + +C<init_encoding()> will return an arrayref of 3 filehandles, STDOUT, STDERR, +and TODO. TODO is typically just STDOUT again. If the encoding specified has +not yet been initialized it will initialize it. If you provide filehandles they +will be used, but only during initializatin. Typically a filehandle set is +created by cloning STDER and STDOUT and modifying them to use the correct +encoding. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/Meta.pm new file mode 100644 index 0000000000..9f7b6d38c3 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Meta.pm @@ -0,0 +1,202 @@ +package Test::Stream::Meta; +use strict; +use warnings; + +use Scalar::Util(); +use Test::Stream::Util qw/protect/; + +use Test::Stream::ArrayBase( + accessors => [qw/package encoding modern todo stream/], +); + +use Test::Stream::PackageUtil; + +use Test::Stream::Exporter qw/import export_to default_exports/; +default_exports qw{ is_tester init_tester }; +Test::Stream::Exporter->cleanup(); + +my %META; + +sub snapshot { + my $self = shift; + my $class = Scalar::Util::blessed($self); + return bless [@$self], $class; +} + +sub is_tester { + my $pkg = shift; + return $META{$pkg}; +} + +sub init_tester { + my $pkg = shift; + $META{$pkg} ||= bless [$pkg, 'legacy', 0, undef], __PACKAGE__; + return $META{$pkg}; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Meta - Meta object for unit test packages. + +=head1 DESCRIPTION + +This object is used to track metadata for unit tests packages. + +=head1 SYNOPSYS + + use Test::Stream::Meta qw/init_tester is_tester/; + + sub import { + my $class = shift; + my $caller = caller; + + my $meta = init_tester($caller); + } + + sub check_stuff { + my $caller = caller; + my $meta = is_tester($caller) || return; + + ... + } + +=head1 EXPORTS + +=over 4 + +=item $meta = is_tester($package) + +Get the meta object for a specific package, if it has one. + +=item $meta = init_tester($package) + +Get the meta object for a specific package, or create one. + +=back + +=head1 METHODS + +=over 4 + +=item $meta_copy = $meta->snapshot + +Get a snapshot copy of the metadata. This snapshot will not change when the +original does. + +=item $val = $meta->package + +=item $val = $meta->encoding + +=item $val = $meta->modern + +=item $val = $meta->todo + +=item $val = $meta->stream + +These are various attributes stored on the meta object. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm b/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm new file mode 100644 index 0000000000..e8bb70be49 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm @@ -0,0 +1,188 @@ +package Test::Stream::PackageUtil; +use strict; +use warnings; + +sub confess { require Carp; goto &Carp::confess } + +my @SLOTS = qw/HASH SCALAR ARRAY IO FORMAT CODE/; +my %SLOTS = map {($_ => 1)} @SLOTS; + +sub import { + my $caller = caller; + no strict 'refs'; + *{"$caller\::package_sym"} = \&package_sym; + *{"$caller\::package_purge_sym"} = \&package_purge_sym; + 1; +} + +sub package_sym { + my ($pkg, $slot, $name) = @_; + confess "you must specify a package" unless $pkg; + confess "you must specify a symbol type" unless $slot; + confess "you must specify a symbol name" unless $name; + + confess "'$slot' is not a valid symbol type! Valid: " . join(", ", @SLOTS) + unless $SLOTS{$slot}; + + no warnings 'once'; + no strict 'refs'; + return *{"$pkg\::$name"}{$slot}; +} + +sub package_purge_sym { + my ($pkg, @pairs) = @_; + + for(my $i = 0; $i < @pairs; $i += 2) { + my $purge = $pairs[$i]; + my $name = $pairs[$i + 1]; + + confess "'$purge' is not a valid symbol type! Valid: " . join(", ", @SLOTS) + unless $SLOTS{$purge}; + + no strict 'refs'; + local *GLOBCLONE = *{"$pkg\::$name"}; + undef *{"$pkg\::$name"}; + for my $slot (@SLOTS) { + next if $slot eq $purge; + *{"$pkg\::$name"} = *GLOBCLONE{$slot} if defined *GLOBCLONE{$slot}; + } + } +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::PackageUtil - Utils for manipulating package symbol tables. + +=head1 DESCRIPTION + +Collection of utilities L<Test::Stream> and friends use to manipulate package +symbol tables. This is primarily useful when trackign things like C<$TODO> +vars. It is also used for exporting and meta-construction of object methods. + +=head1 EXPORTS + +Both exports are exported by default, you cannot pick and choose. These work +equally well as functions and class-methods. These will not work as object +methods. + +=over 4 + +=item $ref = package_sym($PACKAGE, $SLOT => $NAME) + +Get the reference to a symbol in the package. C<$PACKAGE> should be the package +name. C<$SLOT> should be a valid typeglob slot (Supported slots: HASH SCALAR ARRAY +IO FORMAT CODE). C<$NAME> should be the name of the symbol. + +=item package_purge_sym($PACKAGE, $SLOT => $NAME, $SLOT2 => $NAME2, ...) + +This is used to remove symbols from a package. The first argument, C<$PACKAGE>, +should be the name of the package. The remaining arguments should be key/value +pairs. The key in each pair should be the typeglob slot to clear (Supported +slots: HASH SCALAR ARRAY IO FORMAT CODE). The value in the pair should be the +name of the symbol to remove. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester.pm b/cpan/Test-Simple/lib/Test/Stream/Tester.pm new file mode 100644 index 0000000000..80e45bd0d5 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester.pm @@ -0,0 +1,725 @@ +package Test::Stream::Tester; +use strict; +use warnings; + +use Test::Builder 1.301001; +use Test::Stream; +use Test::Stream::Util qw/try/; + +use B; + +use Scalar::Util qw/blessed reftype/; +use Test::Stream::Carp qw/croak carp/; + +use Test::Stream::Tester::Checks; +use Test::Stream::Tester::Checks::Event; +use Test::Stream::Tester::Events; +use Test::Stream::Tester::Events::Event; + +use Test::Stream::Toolset; +use Test::Stream::Exporter; +default_exports qw{ + intercept grab + + events_are + check event directive +}; + +default_export dir => \&directive; +Test::Stream::Exporter->cleanup; + +sub grab { + require Test::Stream::Tester::Grab; + return Test::Stream::Tester::Grab->new; +} + +our $EVENTS; +sub check(&) { + my ($code) = @_; + + my $o = B::svref_2object($code); + my $st = $o->START; + my $file = $st->file; + my $line = $st->line; + + local $EVENTS = Test::Stream::Tester::Checks->new($file, $line); + + my @out = $code->($EVENTS); + + if (@out) { + if ($EVENTS->populated) { + carp "sub used in check(&) returned values, did you forget to prefix an event with 'event'?" + } + else { + croak "No events were produced by sub in check(&), but the sub returned some values, did you forget to prefix an event with 'event'?"; + } + } + + return $EVENTS; +} + +sub event($$) { + my ($type, $data) = @_; + + croak "event() cannot be used outside of a check { ... } block" + unless $EVENTS; + + my $etypes = Test::Stream::Context->events; + croak "'$type' is not a valid event type!" + unless $etypes->{$type}; + + my $props; + + croak "event() takes a type, followed by a hashref" + unless ref $data && reftype $data eq 'HASH'; + + # Make a copy + $props = { %{$data} }; + + my @call = caller(0); + $props->{debug_package} = $call[0]; + $props->{debug_file} = $call[1]; + $props->{debug_line} = $call[2]; + + $EVENTS->add_event($type, $props); + return (); +} + +sub directive($;$) { + my ($directive, @args) = @_; + + croak "directive() cannot be used outside of a check { ... } block" + unless $EVENTS; + + croak "No directive specified" + unless $directive; + + if (!ref $directive) { + croak "Directive '$directive' requires exactly 1 argument" + unless (@args && @args == 1) || $directive eq 'end'; + } + else { + croak "directives must be a predefined name, or a sub ref" + unless reftype($directive) eq 'CODE'; + } + + $EVENTS->add_directive(@_); + return (); +} + +sub intercept(&) { + my ($code) = @_; + + my @events; + + my ($ok, $error) = try { + Test::Stream->intercept( + sub { + my $stream = shift; + $stream->listen( + sub { + shift; # Stream + push @events => @_; + } + ); + $code->(); + } + ); + }; + + die $error unless $ok || (blessed($error) && $error->isa('Test::Stream::Event')); + + return \@events; +} + +sub events_are { + my ($events, $checks, $name) = @_; + + croak "Did not get any events" + unless $events; + + croak "Did not get any checks" + unless $checks; + + croak "checks must be an instance of Test::Stream::Tester::Checks" + unless blessed($checks) + && $checks->isa('Test::Stream::Tester::Checks'); + + my $ctx = context(); + + # use $_[0] directly so that the variable used in the method call can be undef'd + $events = $_[0]->finish + if blessed($events) + && $events->isa('Test::Stream::Tester::Grab'); + + $events = Test::Stream::Tester::Events->new(@$events) + if ref($events) + && reftype($events) eq 'ARRAY'; + + croak "'$events' is not a valid set of events." + unless $events + && blessed($events) + && $events->isa('Test::Stream::Tester::Events'); + + my ($ok, @diag) = $checks->run($events); + + $ctx->ok($ok, $name, \@diag); + return $ok; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Tester - Tools for validating the events produced by your testing +tools. + +=head1 DESCRIPTION + +There are tools to validate your code. This library provides tools to validate +your tools! + +=head1 SYNOPSIS + + use Test::More; + use Test::Stream::Tester; + + events_are( + # Capture all the events within the block + intercept { + ok(1, "pass"); + ok(0, "fail"); + diag("xxx"); + }, + + # Describe what we expect to see + check { + event ok => {bool => 1, name => 'pass'}; + event ok => { + bool => 0, + name => 'fail', + + # Ignores any fields in the result we don't list + # real_bool, line, file, tool_package, tool_name, etc... + + # Diagnostics generated by a test are typically linked to those + # results (new and updated tools only) They can be validated. + diag => qr/^Failed test /, + }; + event diag => {message => 'xxx'}; + directive 'end'; # enforce that there are no more results + }, + + "This is the name of our test" + ); + + done_testing; + +=head2 GRAB WITH NO ADDED STACK + + use Test::More; + use Test::Stream::Tester; + + # Start capturing events. We use grab() instead of intercept {} to avoid + # adding stack frames. + my $grab = grab(); + + # Generate some events. + ok(1, "pass"); + ok(0, "fail"); + diag("xxx"); + + # Stop capturing events, and validate the ones recieved. + events_are( + $grab, + check { + event ok => { bool => 1, name => 'pass' }; + event ok => { bool => 0, name => 'fail' }; + event diag => { message => 'xxx' }; + directive 'end'; + }, + 'Validate our Grab results'; + ); + + # $grab is now undef, it no longer exists. + is($grab, undef, '$grab was destroyed for us.'); + + ok(!$success, "Eval did not succeed, BAIL_OUT killed the test"); + + # Make sure we got the event as an exception + isa_ok($error, 'Test::Stream::Event::Bail'); + + done_testing + +=head1 EXPORTS + +=over 4 + +=item $events = intercept { ... } + +=item $events = intercept(sub { ... }) + +Capture the L<Test::Builder::Event> objects generated by tests inside the block. + +=item events_are(\@events, $check) + +=item events_are(\@events, $check, $name) + +=item events_are($events, $check) + +=item events_are($events, $check, $name) + +=item events_are($grab, $check) + +=item events_are($grab, $check, $name) + +The first argument may be either an arrayref of L<Test::Stream::Event> objects, +an L<Test::Stream::Tester::Grab> object, or an L<Test::Stream::Tester::Events> +object. C<intercept { ... }> can be used to capture events within a block of +code, including plans such as C<skip_all>, and things that normally kill the +test like C<BAIL_OUT()>. + +The second argument must be an L<Test::Stream::Tester::Checks> object. +Typically these are generated using C<check { ... }>. + +The third argument is the name of the test, it is optional, but highly +recommended. + +=item $checks = check { ... }; + +Produce an array of expected events for use in events_are. + + my $check = check { + event ok => { ... }; + event diag => { ... }; + directive 'end'; + }; + +If the block passed to check returns anything at all it will warn you as this +usually means you forgot to use the C<event> and/or C<diag> functions. If it +returns something AND has no events it will be fatal. + +C<event()> and C<directive()> both return nothing, this means that if you use +them alone your codeblock will return nothing. + +=item event TYPE => { ... }; + +Define an event and push it onto the list that will be returned by the +enclosing C<check { ... }> block. Will fail if run outside a check block. This +will fail if you give it an invalid event type. + +If you wish to acknowledge the event, but not check anything you may simply +give it an empty hashref. + +The line number where the event was generated is recorded for helpful debugging +in event of a failure. + +B<CAVEAT> The line number is inexact because of the way perl records it. The +line number is taken from C<caller>. + +=item dir 'DIRECTIVE'; + +=item dir DIRECTIVE => 'ARG'; + +=item dir sub { ... }; + +=item dir sub { ... }, $arg; + +=item directive 'DIRECTIVE'; + +=item directive DIRECTIVE => 'ARG'; + +=item directive sub { ... }; + +=item directive sub { ... }, $arg; + +Define a directive and push it onto the list that will be returned by the +enclosing C<check { ... }> block. This will fail if run outside of a check +block. + +The first argument must be either a codeblock, or one of the name of a +predefined directive I<See the directives section>. + +Coderefs will be given 3 arguments: + + sub { + my ($checks, $events, $arg) = @_; + ... + } + +C<$checks> is the L<Test::Stream::Tester::Checks> object. C<$events> is the +L<Test::Stream::Tester::Events> object. C<$arg> is whatever argument you passed +via the C<directive()> call. + +Most directives will act on the C<$events> object to remove or alter events. + +=back + +=head1 INTERCEPTING EVENTS + + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + diag("xxx"); + }; + +Any events generated within the block will be intercepted and placed inside +the C<$events> array reference. + +=head2 EVENT TYPES + +All events will be subclasses of L<Test::Builder::Event> + +=over 4 + +=item L<Test::Builder::Event::Ok> + +=item L<Test::Builder::Event::Note> + +=item L<Test::Builder::Event::Diag> + +=item L<Test::Builder::Event::Plan> + +=item L<Test::Builder::Event::Finish> + +=item L<Test::Builder::Event::Bail> + +=item L<Test::Builder::Event::Subtest> + +=back + +=head1 VALIDATING EVENTS + +You can validate events by hand using traditional test tools such as +C<is_deeply()> against the $events array returned from C<intercept()>. However +it is easier to use C<events_are()> paried with C<checks> objects build using +C<checks { ... }>. + + events_are( + intercept { + ok(1, "pass"); + ok(0, "fail"); + diag("xxx"); + }, + + check { + event ok => { bool => 1, name => 'pass' }; + event ok => { bool => 0, name => 'fail' }; + event diag => {message => 'xxx'}; + directive 'end'; + }, + + "This is the name of our test" + ); + +=head2 WHAT DOES THIS BUY ME? + +C<checks { ... }>, C<event()>, and C<directive()>, work together to produce a +nested set of objects to represent what you want to see. This was chosen over a +hash/list system for 2 reasons: + +=over 4 + +=item Better Diagnostics + +Whenever you use C<checks { ... }>, C<events()>, and C<directive()> it records +the filename and line number where they are called. When a test fails the +diagnostics will include this information so that you know where the error +occured. In a hash/list based system this information is not available. + +A hash based system is not practical as you may generate several events of the +same type, and in a hash duplicated keys are squashed (last one wins). + +A list based system works, but then a failure reports the index of the failure, +this requires you to manually count events to find the correct one. Originally +I tried letting you specify an ID for the events, but this proved annoying. + +Ultimately I am very happy with the diagnostics this allows. It is very nice to +see what is essentially a simple trace showing where the event and check were +generated. It also shows you the items leading to the failure in the event of +nested checks. + +=item Loops and other constructs + +In a list based system you are limited in what you can produce. You can +generate the list in advance, then pass it in, but this is hard to debug. +Alternatively you can use C<map> to produce repeated events, but this is +equally hard to debug. + +This system lets you call C<event()> and C<directive()> in loops directly. It +also lets you write functions that produce them based on input for reusable +test code. + +=back + +=head2 VALIDATING FIELDS + +The hashref against which events are checked is composed of keys, and values. +The values may be regular values, which are checked for equality with the +corresponding property of the event object. Alternatively you can provide a +regex to match against, or an arrayref of regexes (each one must match). + +=over 4 + +=item field => 'exact_value', + +The specified field must exactly match the given value, be it number or string. + +=item field => qr/.../, + +The specified field must match the regular expression. + +=item field => [qr/.../, qr/.../, ...], + +The value of the field must match ALL the regexes. + +=item field => sub { ... } + +Specify a sub that will validate the value of the field. + + foo => sub { + my ($key, $val) = @_; + + ... + + # Return true (valid) or false, and any desired diagnostics messages. + return($bool, @diag); + }, + +=back + +=head2 WHAT FIELDS ARE AVAILABLE? + +This is specific to the event type. All events inherit from +L<Test::Builder::Event> which provides a C<summary()> method. The C<summary()> +method returns a list of key/value pairs I<(not a reference!)> with all fields +that are for public consumption. + +For each of the following modules see the B<SUMMARY FIELDS> section for a list +of fields made available. These fields are inherited when events are +subclassed, and all events have the summary fields present in +L<Test::Builder::Event>. + +=over 4 + +=item L<Test::Builder::Event/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Ok/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Note/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Diag/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Plan/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Finish/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Bail/"SUMMARY FIELDS"> + +=item L<Test::Builder::Event::Subtest/"SUMMARY FIELDS"> + +=back + +=head2 DIRECTIVES + +Directives give you a chance to alter the list of events part-way through the +check, or to make the check skip/ignore events based on conditions. + +=head3 skip + +Skip will skip a specific number of events at that point in the check. + +=over 4 + +=item directive skip => $num; + + my $events = intercept { + ok(1, "foo"); + diag("XXX"); + + ok(1, "bar"); + diag("YYY"); + + ok(1, "baz"); + diag("ZZZ"); + }; + + events_are( + $events, + ok => { name => "foo" }, + + skip => 1, # Skips the diag 'XXX' + + ok => { name => "bar" }, + + skip => 2, # Skips the diag 'YYY' and the ok 'baz' + + diag => { message => 'ZZZ' }, + ); + +=back + +=head3 seek + +When turned on (true), any unexpected events will be skipped. You can turn +this on and off any time by using it again with a false argument. + +=over 4 + +=item directive seek => $BOOL; + + my $events = intercept { + ok(1, "foo"); + + diag("XXX"); + diag("YYY"); + + ok(1, "bar"); + diag("ZZZ"); + + ok(1, "baz"); + }; + + events_are( + $events, + + seek => 1, + ok => { name => "foo" }, + # The diags are ignored, it will seek to the next 'ok' + ok => { name => "bar" }, + + seek => 0, + + # This will fail because the diag is not ignored anymore. + ok => { name => "baz" }, + ); + +=back + +=head3 end + +Used to say that there should not be any more events. Without this any events +after your last check are simply ignored. This will generate a failure if any +unchecked events remain. + +=over 4 + +=item directive 'end'; + +=back + +=head1 SEE ALSO + +=over 4 + +=item L<Test::Tester> *Deprecated* + +A nice, but very limited tool for testing 'ok' results. + +=item L<Test::Builder::Tester> *Deprecated* + +The original test tester, checks TAP output as giant strings. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm new file mode 100644 index 0000000000..9321fe8f2c --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm @@ -0,0 +1,401 @@ +package Test::Stream::Tester::Checks; +use strict; +use warnings; + +use Test::Stream::Carp qw/croak confess/; +use Test::Stream::Util qw/is_regex/; + +use Scalar::Util qw/blessed reftype/; + +my %DIRECTIVES = ( + map { $_ => __PACKAGE__->can($_) } + qw(filter_providers filter_types skip seek end) +); + +sub new { + my $class = shift; + my ($file, $line) = @_; + my $self = bless { + seek => 0, + items => [], + file => $file, + line => $line, + }, $class; + return $self; +} + +sub debug { + my $self = shift; + return "Checks from $self->{file} around line $self->{line}."; +} + +sub populated { scalar @{shift->{items}} } + +sub add_directive { + my $self = shift; + my ($dir, @args) = @_; + + confess "No directive provided!" + unless $dir; + + if (ref($dir)) { + confess "add_directive takes a coderef, or name, and optional args. (got $dir)" + unless reftype($dir) eq 'CODE'; + } + else { + confess "$dir is not a valid directive." + unless $DIRECTIVES{$dir}; + $dir = $DIRECTIVES{$dir}; + } + + push @{$self->{items}} => [$dir, @args]; +} + +sub add_event { + my $self = shift; + my ($type, $spec) = @_; + + confess "add_event takes a type name and a hashref" + unless $type && $spec && ref $spec && reftype($spec) eq 'HASH'; + + my $e = Test::Stream::Tester::Checks::Event->new(%$spec, type => $type); + push @{$self->{items}} => $e; +} + +sub include { + my $self = shift; + my ($other) = @_; + + confess "Invalid argument to include()" + unless $other && blessed($other) && $other->isa(__PACKAGE__); + + push @{$self->{items}} => @{$other->{items}}; +} + +sub run { + my $self = shift; + my ($events) = @_; + $events = $events->clone; + + for (my $i = 0; $i < @{$self->{items}}; $i++) { + my $item = $self->{items}->[$i]; + + # Directive + if (reftype $item eq 'ARRAY') { + my ($code, @args) = @$item; + my @out = $self->$code($events, @args); + next unless @out; + return @out; + } + + # Event! + my $meth = $self->{seek} ? 'seek' : 'next'; + my $event = $events->$meth($item->get('type')); + + my ($ret, @debug) = $self->check_event($item, $event); + return ($ret, @debug) unless $ret; + } + + return (1); +} + +sub vtype { + my ($v) = @_; + + if (blessed($v)) { + return 'checks' if $v->isa('Test::Stream::Tester::Checks'); + return 'events' if $v->isa('Test::Stream::Tester::Events'); + return 'check' if $v->isa('Test::Stream::Tester::Checks::Event'); + return 'event' if $v->isa('Test::Stream::Tester::Events::Event'); + } + + return 'regexp' if defined is_regex($v); + return 'noref' unless ref $v; + return 'array' if reftype($v) eq 'ARRAY'; + return 'code' if reftype($v) eq 'CODE'; + + confess "Invalid field check: '$v'"; +} + +sub check_event { + my $self = shift; + my ($want, $got) = @_; + + my @debug = (" Check: " . $want->debug); + my $wtype = $want->get('type'); + + return (0, @debug, " Expected event of type '$wtype', but did not find one.") + unless defined($got); + + unshift @debug => " Event: " . $got->debug; + my $gtype = $got->get('type'); + + return (0, @debug, " Expected event of type '$wtype', but got '$gtype'.") + unless $wtype eq $gtype; + + for my $key ($want->keys) { + my $wval = $want->get($key); + my $gval = $got->get($key); + + my ($ret, @err) = $self->check_key($key, $wval, $gval); + return ($ret, @debug, @err) unless $ret; + } + + return (1); +} + +sub check_key { + my $self = shift; + my ($key, $wval, $gval) = @_; + + if ((defined $wval) xor(defined $gval)) { + $wval = defined $wval ? "'$wval'" : 'undef'; + $gval = defined $gval ? "'$gval'" : 'undef'; + return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval",); + } + + my $wtype = vtype($wval); + + my $meth = "_check_field_$wtype"; + return $self->$meth($key, $wval, $gval); +} + +sub _check_field_checks { + my $self = shift; + my ($key, $wval, $gval) = @_; + + my $debug = $wval->debug; + + return (0, " \$got->{$key} = '$gval'", " \$exp->{$key} = <$debug>") + unless vtype($gval) eq 'events'; + + my ($ret, @diag) = $wval->run($gval); + return $ret if $ret; + return ($ret, map { s/^/ /mg; $_ } @diag); +} + +sub _check_field_check { + my $self = shift; + my ($key, $wval, $gval) = @_; + + my $debug = $wval->debug; + + return (0, "Event: INVALID EVENT ($gval)", " Check: $debug") + unless vtype($gval) eq 'event'; + + my ($ret, @diag) = check_event($wval, $gval); + return $ret if $ret; + + return ($ret, map { s/^/ /mg; $_ } @diag); +} + +sub _check_field_noref { + my $self = shift; + my ($key, $wval, $gval) = @_; + + return (1) if !defined($wval) && !defined($gval); + return (1) if defined($wval) && defined($gval) && "$wval" eq "$gval"; + $wval = "'$wval'" if defined $wval; + $wval ||= 'undef'; + $gval = "'$gval'" if defined $gval; + $gval ||= 'undef'; + return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval"); +} + +sub _check_field_regexp { + my $self = shift; + my ($key, $wval, $gval) = @_; + + return (1) if $gval =~ /$wval/; + return (0, " \$got->{$key} = '$gval'", " Does not match $wval"); +} + +sub _check_field_array { + my $self = shift; + my ($key, $wval, $gval) = @_; + for my $p (@$wval) { + my ($ret, @diag) = $self->_check_field_regexp($key, $p, $gval); + return ($ret, @diag) unless $ret; + } + + return (1); +} + +sub _check_field_code { + my $self = shift; + my ($key, $wval, $gval) = @_; + $wval->($key, $gval); +} + +sub seek { + my $self = shift; + my ($events, $flag) = @_; + + $self->{seek} = $flag ? 1 : 0; + + return (); # Cannot fail +} + +sub skip { + my $self = shift; + my ($events, $num) = @_; + $events->next while $num--; + return (); +} + +sub end { + my $self = shift; + my ($events) = @_; + my $event = $events->next; + return () unless $event; + return (0, " Expected end of events, got " . $event->debug); +} + +sub filter_providers { + my $self = shift; + my ($events, $arg) = @_; + + my ($neg, $val) = $arg =~ m/^(!?)(.*)$/; + if ($neg) { + @$events = grep { $_->get('tool_package') ne $val } @$events; + } + else { + @$events = grep { $_->get('tool_package') eq $val } @$events; + } + + return (); +} + +sub filter_types { + my $self = shift; + my ($events, $arg) = @_; + + my ($neg, $val) = $arg =~ m/^(!?)(.*)$/; + if ($neg) { + @$events = grep { $_->get('type') ne $val } @$events; + } + else { + @$events = grep { $_->get('type') eq $val } @$events; + } + + return (); +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Tester::Checks - Representation of a L<Test::Stream::Tester> +event check. + +=head1 DESCRIPTION + +L<Test::Stream::Tester> produces this object whenever you use C<check { ... }>. +In general you will not interact with this object directly beyond pasing it +into C<events_are>. + +B<Note:> The API for this object is not published and is subject to change. No backwords +compatability can be guarenteed if you use this object directly. Please only +use this object in the published way specified in L<Test::Stream::Tester>. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm new file mode 100644 index 0000000000..84517aacd9 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm @@ -0,0 +1,194 @@ +package Test::Stream::Tester::Checks::Event; +use strict; +use warnings; + +use Test::Stream::Util qw/is_regex/; +use Test::Stream::Carp qw/confess croak/; + +use Scalar::Util qw/blessed reftype/; + +sub new { + my $class = shift; + my $fields = {@_}; + my $self = bless {fields => $fields}, $class; + + $self->{$_} = delete $fields->{$_} + for qw/debug_line debug_file debug_package/; + + map { $self->validate_check($_) } values %$fields; + + my $type = $self->get('type') || confess "No type specified!"; + + my $etypes = Test::Stream::Context->events; + confess "'$type' is not a valid event type" + unless $etypes->{$type}; + + return $self; +} + +sub debug_line { shift->{debug_line} } +sub debug_file { shift->{debug_file} } +sub debug_package { shift->{debug_package} } + +sub debug { + my $self = shift; + + my $type = $self->get('type'); + my $file = $self->debug_file; + my $line = $self->debug_line; + + return "'$type' from $file line $line."; +} + +sub keys { sort keys %{shift->{fields}} } + +sub exists { + my $self = shift; + my ($field) = @_; + return exists $self->{fields}->{$field}; +} + +sub get { + my $self = shift; + my ($field) = @_; + return $self->{fields}->{$field}; +} + +sub validate_check { + my $self = shift; + my ($val) = @_; + + return unless defined $val; + return unless ref $val; + return if defined is_regex($val); + + if (blessed($val)) { + return if $val->isa('Test::Stream::Tester::Checks'); + return if $val->isa('Test::Stream::Tester::Events'); + return if $val->isa('Test::Stream::Tester::Checks::Event'); + return if $val->isa('Test::Stream::Tester::Events::Event'); + } + + my $type = reftype($val); + return if $type eq 'CODE'; + + croak "'$val' is not a valid field check" + unless reftype($val) eq 'ARRAY'; + + croak "Arrayrefs given as field checks may only contain regexes" + if grep { ! defined is_regex($_) } @$val; + + return; +} + +1; + +=head1 NAME + +Test::Stream::Tester::Checks::Event - Representation of an event validation +specification. + +=head1 DESCRIPTION + +Used internally by L<Test::Stream::Tester>. Please do not use directly. No +backwords compatability will be provided if the API for this module changes. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm new file mode 100644 index 0000000000..36ee93ec64 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm @@ -0,0 +1,166 @@ +package Test::Stream::Tester::Events; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +use Test::Stream::Tester::Events::Event; + +sub new { + my $class = shift; + my $self = bless [map { Test::Stream::Tester::Events::Event->new($_->summary) } @_], $class; + return $self; +} + +sub next { shift @{$_[0]} }; + +sub seek { + my $self = shift; + my ($type) = @_; + + while (my $e = shift @$self) { + return $e if $e->{type} eq $type; + } + + return undef; +} + +sub clone { + my $self = shift; + my $class = blessed($self); + return bless [@$self], $class; +} + +1; + +=head1 NAME + +Test::Stream::Tester::Events - Event list used by L<Test::Stream::Tester>. + +=head1 DESCRIPTION + +L<Test::Stream::Tester> converts lists of events into instances of this object +for use in various tools. You will probably never need to directly use this +class. + +=head1 METHODS + +=over 4 + +=item $events = $class->new(@EVENTS); + +Create a new instance from a list of events. + +=item $event = $events->next + +Get the next event. + +=item $event = $events->seek($type) + +Get the next event of the specific type (not a package name). + +=item $copy = $events->clone() + +Clone the events list object in its current state. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm new file mode 100644 index 0000000000..f4265ad830 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm @@ -0,0 +1,199 @@ +package Test::Stream::Tester::Events::Event; +use strict; +use warnings; + +use Test::Stream::Carp qw/confess/; +use Scalar::Util qw/reftype blessed/; + +sub new { + my $class = shift; + my $self = bless {}, $class; + + my @orig = @_; + + while (@_) { + my $field = shift; + my $val = shift; + + if (exists $self->{$field}) { + use Data::Dumper; + print Dumper(@orig); + confess "'$field' specified more than once!"; + } + + if (my $type = reftype $val) { + if ($type eq 'ARRAY') { + $val = Test::Stream::Tester::Events->new(@$val) + unless grep { !blessed($_) || !$_->isa('Test::Stream::Event') } @$val; + } + elsif (blessed($val) && $val->isa('Test::Stream::Event')) { + $val = $class->new($val->summary); + } + } + + $self->{$field} = $val; + } + + return $self; +} + +sub get { + my $self = shift; + my ($field) = @_; + return $self->{$field}; +} + +sub debug { + my $self = shift; + + my $type = $self->get('type'); + my $file = $self->get('file'); + my $line = $self->get('line'); + + return "'$type' from $file line $line."; +} + +1; + +=head1 NAME + +Test::Stream::Tester::Events::Event - L<Test::Stream::Tester> representation of +an event. + +=head1 DESCRIPTION + +L<Test::Stream::Tester> often uses this clas to represent events in a way that +is easier to validate. + +=head1 SYNOPSYS + + use Test::Stream::Tester::Events::Event; + + my $event = Test::Stream::Tester::Events::Event->new($e->summary); + + # Print the file and line number where the event was generated + print "Debug: " . $event->debug . "\n"; + + # Get an event field value + my $val = $event->get($field); + +=head1 METHODS + +=over 4 + +=item $event->get($field) + +Get the value of a specific event field. Fields are specific to event types. +The fields are usually the result of calling C<< $e->summary >> on the original +event. + +=item $event->debug + +Returns a string like this: + + 'ok' from my_test.t line 42. + +Which lists the type of event, the file that generated, and the line number on +which it was generated. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm new file mode 100644 index 0000000000..bf2ab5ffcc --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm @@ -0,0 +1,215 @@ +package Test::Stream::Tester::Grab; +use strict; +use warnings; + +sub new { + my $class = shift; + + my $self = bless { + events => [], + streams => [ Test::Stream->intercept_start ], + }, $class; + + $self->{streams}->[0]->listen( + sub { + shift; # Stream + push @{$self->{events}} => @_; + } + ); + + return $self; +} + +sub flush { + my $self = shift; + my $out = delete $self->{events}; + $self->{events} = []; + return $out; +} + +sub events { + my $self = shift; + # Copy + return [@{$self->{events}}]; +} + +sub finish { + my ($self) = @_; # Do not shift; + $_[0] = undef; + + $self->{finished} = 1; + my ($remove) = $self->{streams}->[0]; + Test::Stream->intercept_stop($remove); + + return $self->flush; +} + +sub DESTROY { + my $self = shift; + return if $self->{finished}; + my ($remove) = $self->{streams}->[0]; + Test::Stream->intercept_stop($remove); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Test::Stream::Tester::Grab - Object used to temporarily steal all events. + +=head1 DESCRIPTION + +Once created this object will intercept and stash all events sent to the shared +L<Test::Stream> object. Once the object is destroyed events will once again be +sent to the shared stream. + +=head1 SYNOPSYS + + use Test::More; + use Test::Stream::Tester::Grab; + + my $grab = Test::Stream::Tester::Grab->new(); + + # Generate some events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + my $events_a = $grab->flush; + + # Generate some more events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + # Same as flush, except it destroys the grab object. + my $events_b = $grab->finish; + +After calling C<finish()> the grab object is destroyed and C<$grab> is set to +undef. C<$events_a> is an arrayref with the first 2 events. C<$events_b> is an +arrayref with the second 2 events. + +=head1 METHODS + +=over 4 + +=item $grab = $class->new() + +Create a new grab object, immediately starts intercepting events. + +=item $ar = $grab->flush() + +Get an arrayref of all the events so far, clearing the grab objects internal +list. + +=item $ar = $grab->events() + +Get an arrayref of all events so far, does not clear the internal list. + +=item $ar = $grab->finish() + +Get an arrayref of all the events, then destroy the grab object. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Threads.pm b/cpan/Test-Simple/lib/Test/Stream/Threads.pm new file mode 100644 index 0000000000..e07c9cea6f --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Threads.pm @@ -0,0 +1,163 @@ +package Test::Stream::Threads; +use strict; +use warnings; + +BEGIN { + use Config; + if( $Config{useithreads} && $INC{'threads.pm'} ) { + eval q| + sub get_tid { threads->tid() } + sub USE_THREADS() { 1 } + 1; + | || die $@; + } + else { + eval q| + sub get_tid() { 0 } + sub USE_THREADS() { 0 } + 1; + | || die $@; + } +} + +use Test::Stream::Exporter; +default_exports qw/get_tid USE_THREADS/; +Test::Stream::Exporter->cleanup; + +1; + +__END__ + +=head1 NAME + +Test::Stream::Threads - Tools for using threads with Test::Stream. + +=head1 DESCRIPTION + +This module provides some helpers for Test::Stream and Toolsets to use to +determine if threading is in place. In most cases you will not need to use this +module yourself. + +=head1 SYNOPSYS + + use threads; + use Test::Stream::Threads; + + if (USE_THREADS) { + my $tid = get_tid(); + } + +=head1 EXPORTS + +=over 4 + +=item USE_THREADS + +This is a constant, it is set to true when Test::Stream is aware of, and using, threads. + +=item get_tid + +This will return the id of the current thread when threads are enabled, +otherwise it returns 0. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm new file mode 100644 index 0000000000..74a66bd257 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm @@ -0,0 +1,350 @@ +package Test::Stream::Toolset; +use strict; +use warnings; + +use Test::Stream::Context qw/context/; +use Test::Stream::Meta qw/is_tester init_tester/; + +# Preload these so the autoload is not necessary +use Test::Stream::Event::Bail; +use Test::Stream::Event::Child; +use Test::Stream::Event::Diag; +use Test::Stream::Event::Finish; +use Test::Stream::Event::Note; +use Test::Stream::Event::Ok; +use Test::Stream::Event::Plan; +use Test::Stream::Event::Subtest; + +use Test::Stream::Exporter qw/import export_to default_exports/; +default_exports qw/is_tester init_tester context/; +Test::Stream::Exporter->cleanup(); + +1; + +=head1 NAME + +Test::Stream::Toolset - Helper for writing testing tools + +=head1 DESCRIPTION + +This package provides you with tools to write testing tools. It makes your job +of integrating with L<Test::Builder> and other testing tools much easier. + +=head1 SYNOPSYS + + package My::Tester; + use strict; + use warnings; + use Test::Stream::Toolset; + + # Optional, you can just use Exporter if you would like + use Test::Stream::Exporter; + + # These can come from Test::More, so do not export them by default + # exports is the Test::Stream::Exporter equivilent to @EXPORT_OK + exports qw/context done_testing/; + + # These are the API we want to provide, export them by default + # default_exports is the Test::Stream::Exporter equivilent to @EXPORT + default_exports qw/my_ok my_note/; + + sub my_ok { + my ($test, $name) = @_; + my $ctx = context(); + + my @diag; + push @diag => "'$test' is not true!" unless $test; + + $ctx->ok($test, $name, \@diag); + + return $test ? 1 : 0; # Reduce to a boolean + } + + sub my_note { + my ($msg) = @_; + my $ctx = context(); + + $ctx->note($msg); + + return $msg; + } + + sub done_testing { + my ($expected) = @_; + my $ctx = context(); + $ctx->done_testing($expected); + } + + 1; + +=head1 EXPORTS + +=over 4 + +=item $ctx = context() + +The context() method is used to get the current context, generating one if +necessary. The context object is an instance of L<Test::Stream::Context>, and +is used to generate events suck as C<ok> and C<plan>. The context also knows +what file+line errors should be reported at. + +B<WARNING:> Do not directly store the context in anything other than a lexical +variable scoped to your function! As long as there are references to a context +object, C<context()> will return that object. You want the object to be +destroyed at the end of the current scope so that the next function you call +can create a new one. If you need a copy of the context use +C<< $ctx = $ctx->snapshot >>. + +=item $meta = init_tester($CLASS) + +This method can be used to initialize a class as a test class. In most cases +you do not actually need to use this. If the class is already a tester this +will return the existing meta object. + +=item $meta = is_tester($CLASS) + +This method can be used to check if an object is a tester. If the object is a +tester it will return the meta object for the tester. + +=back + +=head1 GENERATING EVENTS + +Events are always generated via a context object. Whenever you load an +L<Test::Stream::Event> class it will add a method to L<Test::Stream::Context> +which can be used to fire off that type of event. + +The following event types are all loaded automatically by +L<Test::Stream::Toolset> + +=over 4 + +=item L<Test::Stream::Event::Ok> + + $ctx->ok($bool, $name, \@diag) + +Ok events are your actual assertions. You assert that a condition is what you +expect. It is recommended that you name your assertions. You can include an +array of diag objects and/or diagniostics strings that will be printed to +STDERR as comments in the event of a failure. + +=item L<Test::Stream::Event::Diag> + + $ctx->diag($MESSAGE) + +Produce an independant diagnostics message. + +=item L<Test::Stream::Event::Note> + + $ctx->note($MESSAGE) + +Produce a note, that is a message that is printed to STDOUT as a comment. + +=item L<Test::Stream::Event::Plan> + + $ctx->plan($MAX, $DIRECTIVE, $REASON) + +This will set the plan. C<$MAX> should be the number of tests you expect to +run. You may set this to 0 for some plan directives. Examples of directives are +C<'skip_all'> and C<'no_plan'>. Some directives have an additional argument +called C<$REASON> which is aptly named as the reason for the directive. + +=item L<Test::Stream::Event::Bail> + + $ctx->bail($MESSAGE) + +In the event of a catostrophic failure that should terminate the test file, use +this event to stop everything and print the reason. + +=item L<Test::Stream::Event::Finish> + +=item L<Test::Stream::Event::Child> + +=item L<Test::Stream::Event::Subtest> + +These are not intended for public use, but are documented for completeness. + +=back + +=head1 MODIFYING EVENTS + +If you want to make changes to event objects before they are processed, you can +add a munger. The return from a munger is ignored, you must make your changes +directly to the event object. + + Test::Stream->shared->munge(sub { + my ($stream, $event) = @_; + ... + }); + +B<Note:> every munger is called for every event of every type. There is also no +way to remove a munger. For performance reasons it is best to only ever add one +munger per toolset which dispatches according to events and state. + +=head1 LISTENING FOR EVENTS + +If you wish to know when an event has occured so that you can do something +after it has been processed, you can add a listener. Your listener will be +called for every single event that occurs, after it has been processed. The +return from a listener is ignored. + + Test::Stream->shared->listen(sub { + my ($stream, $event) = @_; + ... + }); + +B<Note:> every listener is called for every event of every type. There is also no +way to remove a listener. For performance reasons it is best to only ever add one +listener per toolset which dispatches according to events and state. + +=head1 I WANT TO EMBED FUNCTIONALITY FROM TEST::MORE + +Take a look at L<Test::More::Tools> which provides an interfaces to the code in +Test::More. You can use that library to produce booleans and diagnostics +without actually triggering events, giving you the opportunity to generate your +own. + +=head1 FROM TEST::BUILDER TO TEST::STREAM + +This is a list of things people used to override in Test::Builder, and the new +API that should be used instead of overrides. + +=over 4 + +=item ok + +=item note + +=item diag + +=item plan + +In the past people would override these methods on L<Test::Builder>. +L<Test::Stream> now provides a proper API for handling all event types. + +Anything that used to be done via overrides can now be done using +c<Test::Stream->shared->listen(sub { ... })> and +C<Test::Stream->shared->munge(sub { ... })>, which are documented above. + +=item done_testing + +In the past people have overriden C<done_testing()> to insert some code between +the last test and the final plan. The proper way to do this now is with a +follow_up hook. + + Test::Stream->shared->follow_up(sub { + my ($context) = @_; + ... + }); + +There are multiple ways that follow_ups will be triggered, but they are +guarenteed to only be called once, at the end of testing. This will either be +the start of C<done_testing()>, or an END block called after your tests are +complete. + +=back + +=head1 HOW DO I TEST MY TEST TOOLS? + +See L<Test::Stream::Tester>. This library gives you all the tools you need to +test your testing tools. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Util.pm b/cpan/Test-Simple/lib/Test/Stream/Util.pm new file mode 100644 index 0000000000..0ba9354ebb --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Util.pm @@ -0,0 +1,331 @@ +package Test::Stream::Util; +use strict; +use warnings; + +use Scalar::Util qw/reftype blessed/; +use Test::Stream::Exporter qw/import export_to exports/; +use Test::Stream::Carp qw/croak/; + +exports qw{ + try protect spoof is_regex is_dualvar + unoverload unoverload_str unoverload_num + translate_filename +}; + +Test::Stream::Exporter->cleanup(); + +sub protect(&) { + my $code = shift; + + my ($ok, $error); + { + local ($@, $!); + $ok = eval { $code->(); 1 } || 0; + $error = $@ || "Error was squashed!\n"; + } + die $error unless $ok; + return $ok; +} + +sub try(&) { + my $code = shift; + my $error; + my $ok; + + { + local ($@, $!, $SIG{__DIE__}); + $ok = eval { $code->(); 1 } || 0; + unless($ok) { + $error = $@ || "Error was squashed!\n"; + } + } + + return wantarray ? ($ok, $error) : $ok; +} + +sub spoof { + my ($call, $code, @args) = @_; + + croak "The first argument to spoof must be an arrayref with package, filename, and line." + unless $call && @$call == 3; + + croak "The second argument must be a string to run." + if ref $code; + + my $error; + my $ok; + + { + local ($@, $!); + $ok = eval <<" EOT" || 0; +package $call->[0]; +#line $call->[2] "$call->[1]" +$code; +1; + EOT + unless($ok) { + $error = $@ || "Error was squashed!\n"; + } + } + + return wantarray ? ($ok, $error) : $ok; +} + +sub is_regex { + my ($pattern) = @_; + + return undef unless defined $pattern; + + return $pattern if defined &re::is_regexp + && re::is_regexp($pattern); + + my $type = reftype($pattern) || ''; + + return $pattern if $type =~ m/^regexp?$/i; + return $pattern if $type eq 'SCALAR' && $pattern =~ m/^\(\?.+:.*\)$/s; + return $pattern if !$type && $pattern =~ m/^\(\?.+:.*\)$/s; + + my ($re, $opts); + + if ($pattern =~ m{^ /(.*)/ (\w*) $ }sx) { + protect { ($re, $opts) = ($1, $2) }; + } + elsif ($pattern =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx) { + protect { ($re, $opts) = ($2, $3) }; + } + else { + return; + } + + return length $opts ? "(?$opts)$re" : $re; +} + +sub unoverload_str { unoverload(q[""], @_) } + +sub unoverload_num { + unoverload('0+', @_); + + for my $val (@_) { + next unless is_dualvar($$val); + $$val = $$val + 0; + } + + return; +} + +# This is a hack to detect a dualvar such as $! +sub is_dualvar($) { + my($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); +} + +## If Scalar::Util is new enough use it +# This breaks cmp_ok diagnostics +#if (my $sub = Scalar::Util->can('isdual')) { +# no warnings 'redefine'; +# *is_dualvar = $sub; +#} + +sub unoverload { + my $type = shift; + + protect { require overload }; + + for my $thing (@_) { + if (blessed $$thing) { + if (my $string_meth = overload::Method($$thing, $type)) { + $$thing = $$thing->$string_meth(); + } + } + } +} + +my $NORMALIZE = undef; +sub translate_filename { + my ($encoding, $orig) = @_; + + return $orig if $encoding eq 'legacy'; + + my $decoded; + require Encode; + try { $decoded = Encode::decode($encoding, "$orig", Encode::FB_CROAK()) }; + return $orig unless $decoded; + + unless (defined $NORMALIZE) { + $NORMALIZE = try { require Unicode::Normalize; 1 }; + $NORMALIZE ||= 0; + } + $decoded = Unicode::Normalize::NFKC($decoded) if $NORMALIZE; + return $decoded || $orig; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::Util - Tools used by Test::Stream and friends. + +=head1 DESCRIPTION + +Collection of tools used by L<Test::Stream> and friends. + +=head1 EXPORTS + +=over 4 + +=item $success = try { ... } + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and optionally 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 spoof([$package, $file, $line], "Code String", @args) + +Eval the string provided as the second argument pretending to be the specified +package, file, and line number. The main purpose of this is to have warnings +and exceptions be thrown from the desired context. + +Additional arguments will be added to an C<@args> variable that is available to +you inside your code string. + +=item $usable_pattern = is_regex($PATTERN) + +Check of the specified argument is a regex. This is mainly important in older +perls where C<qr//> did not work the way it does now. + +=item is_dualvar + +Do not use this, use Scalar::Util::isdual instead. This is kept around for +legacy support. + +=item unoverload + +=item unoverload_str + +=item unoverload_num + +Legacy tools for unoverloading things. + +=item $proper = translate_filename($encoding, $raw) + +Translate filenames from whatever perl has them stored as into the proper, +specified, encoding. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm new file mode 100644 index 0000000000..a413fbfb36 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Tester.pm @@ -0,0 +1,770 @@ +use strict; + +package Test::Tester; + +# Turn this back on later +#warn "Test::Tester is deprecated, see Test::Stream::Tester\n"; + +use Test::Stream 1.301001 '-internal'; +use Test::Builder 1.301001; +use Test::Stream::Toolset; +use Test::More::Tools; +use Test::Stream qw/-internal STATE_LEGACY/; +use Test::Tester::Capture; + +require Exporter; + +use vars qw( @ISA @EXPORT $VERSION ); + +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); +@ISA = qw( Exporter ); + +my $want_space = $ENV{TESTTESTERSPACE}; + +sub show_space { + $want_space = 1; +} + +my $colour = ''; +my $reset = ''; + +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) { + if (eval "require Term::ANSIColor") { + my ($f, $b) = split(",", $want_colour); + $colour = Term::ANSIColor::color($f) . Term::ANSIColor::color("on_$b"); + $reset = Term::ANSIColor::color("reset"); + } + +} + +my $capture = Test::Tester::Capture->new; +sub capture { $capture } + +sub find_depth { + my ($start, $end); + my $l = 1; + while (my @call = caller($l++)) { + $start = $l if $call[3] =~ m/^Test::Builder::(ok|skip|todo_skip)$/; + next unless $start; + next unless $call[3] eq 'Test::Tester::run_tests'; + $end = $l; + last; + } + + return $Test::Builder::Level + 1 unless defined $start && defined $end; + # 2 the eval and the anon sub + return $end - $start - 2; +} + +require Test::Stream::Event::Ok; +my $META = Test::Stream::ArrayBase::Meta->get('Test::Stream::Event::Ok'); +my $idx = $META->{index} + 1; + +sub run_tests { + my $test = shift; + + my $cstream; + if ($capture) { + $cstream = $capture->{stream}; + } + + my ($stream, $old) = Test::Stream->intercept_start($cstream); + $stream->set_use_legacy(1); + $stream->state->[-1] = [0, 0, undef, 1]; + $stream->munge(sub { + my ($stream, $e) = @_; + $e->[$idx] = find_depth() - $Test::Builder::Level; + $e->[$idx+1] = $Test::Builder::Level; + require Carp; + $e->[$idx + 2] = Carp::longmess(); + }); + + my $level = $Test::Builder::Level; + + my @out; + my $prem = ""; + + my $ok = eval { + $test->(); + + for my $e (@{$stream->state->[-1]->[STATE_LEGACY]}) { + if ($e->isa('Test::Stream::Event::Ok')) { + push @out => $e->to_legacy; + $out[-1]->{name} = '' unless defined $out[-1]->{name}; + $out[-1]->{diag} ||= ""; + $out[-1]->{depth} = $e->[$idx]; + for my $d (@{$e->diag || []}) { + next if $d->message =~ m{Failed (\(TODO\) )?test (.*\n\s*)?at .* line \d+\.}; + next if $d->message =~ m{You named your test '.*'\. You shouldn't use numbers for your test names}; + chomp(my $msg = $d->message); + $msg .= "\n"; + $out[-1]->{diag} .= $msg; + } + } + elsif ($e->isa('Test::Stream::Event::Diag')) { + chomp(my $msg = $e->message); + $msg .= "\n"; + if (!@out) { + $prem .= $msg; + next; + } + next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.}; + $out[-1]->{diag} .= $msg; + } + } + + 1; + }; + my $err = $@; + + $stream->state->[-1] = [0, 0, undef, 1]; + + Test::Stream->intercept_stop($stream); + + die $err unless $ok; + + return ($prem, @out); +} + +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) }; + + my $ctx = context(); + + my $ok = !$@; + $ctx->ok($ok, "Test '$name' completed"); + $ctx->diag($@) unless $ok; + + $ok = !length($prem); + $ctx->ok($ok, "Test '$name' no premature diagnostication"); + $ctx->diag("Before any testing anything, your tests said\n$prem") unless $ok; + + cmp_results(\@results, $expects, $name); + return ($prem, @results); +} + +sub cmp_field { + my ($result, $expect, $field, $desc) = @_; + + my $ctx = context(); + if (defined $expect->{$field}) { + my ($ok, @diag) = Test::More::Tools->is_eq( + $result->{$field}, + $expect->{$field}, + ); + $ctx->ok($ok, "$desc compare $field"); + } +} + +sub cmp_result { + my ($result, $expect, $name) = @_; + + my $ctx = context(); + + my $sub_name = $result->{name}; + $sub_name = "" unless defined($name); + + my $desc = "subtest '$sub_name' of '$name'"; + + { + 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) { + $ctx->ok(1, "depth checking is deprecated, dummy pass result..."); + } + + if (defined(my $exp = $expect->{diag})) { + # 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$/); + my $ok = $result->{diag} eq $exp; + $ctx->ok( + $ok, + "subtest '$sub_name' of '$name' compare diag" + ); + unless($ok) { + my $got = $result->{diag}; + 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 + ); + } + + $ctx->diag(<<EOM); +Got diag ($glen bytes): +$got +Expected diag ($elen bytes): +$exp +EOM + + } + } +} + +sub escape { + my $str = shift; + my $res = ''; + for my $char (split("", $str)) { + my $c = ord($char); + if (($c > 32 and $c < 125) or $c == 10) { + $res .= $char; + } + else { + $res .= sprintf('\x{%x}', $c); + } + } + return $res; +} + +sub cmp_results { + my ($results, $expects, $name) = @_; + + my $ctx = context(); + + my ($ok, @diag) = Test::More::Tools->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); + $ctx->ok($ok, @diag); + + for (my $i = 0; $i < @$expects; $i++) { + my $expect = $expects->[$i]; + my $result = $results->[$i]; + + cmp_result($result, $expect, $name); + } +} + +######## nicked from Test::More +sub import { + my $class = shift; + my @plan = @_; + + my $caller = caller; + my $ctx = context(); + + my @imports = (); + foreach my $idx (0 .. $#plan) { + if ($plan[$idx] eq 'import') { + my ($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; + last; + } + } + + my ($directive, $arg) = @plan; + if ($directive eq 'tests') { + $ctx->plan($arg); + } + elsif ($directive) { + $ctx->plan(0, $directive, $arg); + } + + $class->_export_to_level(1, __PACKAGE__, @imports); +} + +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 - *DEPRECATED* Ease testing test modules built with Test::Builder + +=head1 DEPRECATED + +See L<Test::Stream::Tester> for a modern and maintained alternative. + +=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; + + 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<before> 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"); + + +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<This is here for backwards compatibility only> + +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 EVENTS + +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<Test::Builder> 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<Test::Builder> for more details. + +=item reason + +The reason for the skip, todo etc. See L<Test::Builder> 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<after> 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 onwards, +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 + +B<Note:> Depth checking is disabled on newer versions of Test::Builder which no +longer uses $Test::Builder::Level. In these versions this will simple produce a +dummy true result. + +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<Note>: 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<Note>: 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 whitesapce. 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 +show_space() in your test script or set the TESTTESTERSPACE 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 TESTTESTCOLOUR 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 TESTTESTERCOLOR +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<Test::Builder> the source of testing goodness. L<Test::Builder::Tester> +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<exactly> what your test will output. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Tester/Capture.pm b/cpan/Test-Simple/lib/Test/Tester/Capture.pm new file mode 100644 index 0000000000..d63fc8d556 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Tester/Capture.pm @@ -0,0 +1,159 @@ +package Test::Tester::Capture; +use strict; +use warnings; + +use base 'Test::Builder'; +use Test::Stream qw/-internal STATE_LEGACY/; + +sub new { + my $class = shift; + my $self = $class->SUPER::create(@_); + $self->{stream}->set_use_tap(0); + $self->{stream}->set_use_legacy(1); + return $self; +} + +sub details { + my $self = shift; + + my $prem; + my @out; + for my $e (@{$self->{stream}->state->[-1]->[STATE_LEGACY]}) { + if ($e->isa('Test::Stream::Event::Ok')) { + push @out => $e->to_legacy; + $out[-1]->{diag} ||= ""; + $out[-1]->{depth} = $e->level; + for my $d (@{$e->diag || []}) { + next if $d->message =~ m{Failed test .*\n\s*at .* line \d+\.}; + chomp(my $msg = $d->message); + $msg .= "\n"; + $out[-1]->{diag} .= $msg; + } + } + elsif ($e->isa('Test::Stream::Event::Diag')) { + chomp(my $msg = $e->message); + $msg .= "\n"; + if (!@out) { + $prem .= $msg; + next; + } + next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.}; + $out[-1]->{diag} .= $msg; + } + } + + return ($prem, @out) if $prem; + return @out; +} + +1; + +__END__ + +=head1 NAME + +Test::Tester::Capture - Capture module for TesT::Tester + +=head1 DESCRIPTION + +Legacy support for Test::Tester. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod b/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod new file mode 100644 index 0000000000..45713fbaad --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod @@ -0,0 +1,198 @@ +=pod + +=head1 NAME + +Test::Tutorial::WritingTests - A Complete Introduction to writing tests + +=head1 What are tests? + +Tests are code that verifies other code produces the expected output for a +given input. An example may help: + + # This code will die if math doesbn't work. + die "Math is broken" unless 1 + 1 == 2; + +However it is better to use a framework intended for testing: + + ok( 1 + 1 == 2, "Math Works" ); + +This will tell you if the test passes or fails, and will give you extra +information like the name of the test, and what line it was written on if it +fails. + +=head1 Simple example. + + use Test::More; + + ok( 1, "1 is true, this test will pass" ); + ok( 0, "0 is false, this test will fail" ); + + is( 1 + 1, 2, "1 + 1 == 2" ); + + my @array = first_3_numbers(); + + is_deeply( + \@array, + [ 1, 2, 3 ], + "function returned an array of 3 numbers" + ); + + # When you are done, call this to satisfy the plan + done_testing + +See L<Test::More> for C<ok()>, C<is()>, C<is_deeply()>, and several other +useful tools. + +=head1 What is a plan? + +You need to declare how many tests should be seen, this is to ensure your test +does not die partway through. There are 2 ways to declare a plan, 1 way to +decline to make a plan, and a way to skip everything. + +=over 4 + +=item done_testing + + use Test::More; + + ok(1, "pass"); + + done_testing; + +Using done_testing means you do not need to update the plan every time you +change your test script. + +=item Test count + +At import: + + use Test::More tests => 1; + ok(1, "pass"); + +Plan on its own: + + use Test::More; + plan tests => 1; + ok(1, "pass"); + +=item No Plan + + use Test::More 'no_plan'; + +No plan, no way to verify everything ran. + +=item skip_all + + use Test::More skip_all => "We won't run these now"; + +Just don't do anything. + +=back + +=head1 See Also + +L<Test::More> + +=head1 Writing tools. + +See L<Test::Tutorial::WritingTools> + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod b/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod new file mode 100644 index 0000000000..26f4d370a6 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod @@ -0,0 +1,295 @@ +=pod + +=head1 NAME + +Test::Tutorial::WritingTools - How to write testing tools. + +=head1 Examples + +=over 4 + +=item Complete Example + + package My::Tool; + use strict; + use warnings; + + use Test::Stream::Toolset; + use Test::Stream::Exporter; + + # Export 'validate_widget' by default. + default_exports qw/validate_widget/; + + sub validate_widget { + my ($widget, $produces, $name) = @_; + my $ctx = context(); # Do this early as possible + + my $value = $widget->produce; + my $ok = $value eq $produces; + + if ($ok) { + # On success generate an ok event + $ctx->ok($ok, $name); + } + else { + # On failure generate an OK event with some diagnostics + $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]); + } + + # It is usually polite to return a true/false value. + return $ok ? 1 : 0; + } + + 1; + +=item Alternate using Exporter.pm + + package My::Tool; + use strict; + use warnings; + + use Test::Stream::Toolset; + + # Export 'validate_widget' by default. + use base 'Exporter'; + our @EXPORT = qw/validate_widget/; + + sub validate_widget { + my ($widget, $produces, $name) = @_; + my $ctx = context(); # Do this early as possible + + my $value = $widget->produce; + my $ok = $value eq $produces; + + if ($ok) { + # On success generate an ok event + $ctx->ok($ok, $name); + } + else { + # On failure generate an OK event with some diagnostics + $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]); + } + + # It is usually polite to return a true/false value. + return $ok ? 1 : 0; + } + + 1; + +=back + +=head2 Explanation + +L<Test::Stream> is event based. Whenever you want to produce a result you will +generate an event for it. The most common event is L<Test::Stream::Event::Ok>. +Events require some extra information such as where and how they were produced. +In general you do not need to worry about these extra details, they can be +filled in by C<Test::Stream::Context>. + +To get a context object you call C<context()> which can be imported from +L<Test::Stream::Context> itself, or from L<Test::Stream::Toolset>. Once you +have a context object you can ask it to issue events for you. All event types +C<Test::Stream::Event::*> get helper methods on the context object. + +=head2 IMPORTANT NOTE ON CONTEXTS + +The context object has some magic to it. Essentially it is a semi-singleton. +That is if you generate a context object in one place, then try to generate +another one in another place, you will just get the first one again so long as +it still has a reference. If however the first one has fallen out of scope or +been undefined, a new context is generated. + +The idea here is that if you nest functions that use contexts, all levels of +depth will get the same initial context. On the other hand 2 functions run in +sequence will get independant context objects. What this means is that you +should NEVER store a context object in a package variable or object attribute. +You should also never assign it to a variable in a higher scope. + +=head1 Nesting calls to other tools + + use Test::More; + use Test::Stream::Toolset; + + sub compound_check { + my ($object, $name) = @_; + + # Grab the context now for nested tools to find + my $ctx = context; + + my $ok = $object ? 1 : 0; + $ok &&= isa_ok($object, 'Some::Class'); + $ok &&= can_ok($object, qw/foo bar baz/); + $ok &&= is($object->foo, 'my foo', $name); + + $ctx->ok($ok, $name, $ok ? () : ['Not all object checks passed!']); + + return $ok; + } + + 1; + +Nesting tools just works as expected so long as you grab the context BEFORE you +call them. Errors will be reported to the correct file and line number. + +=head1 Useful toolsets to look at + +=over 4 + +=item L<Test::More::Tools> + +This is the collection of tools used by L<Test::More> under the hood. You can +use these instead of L<Test::More> exports to duplicate functionality without +generating extra events. + +=back + +=head1 Available Events + +Anyone can add an event by shoving it in the C<Test::Stream::Event::*> +namespace. It will autoload if C<< $context->event_name >> is called. But here +is the list of events that come with L<Test::Stream>. + +=over 4 + +=item L<Test::Stream::Event::Ok> + + $ctx->ok($bool, $name); + $ctx->ok($bool, $name, \@diag); + +Generate an Ok event. + +=item L<Test::Stream::Event::Diag> + + $ctx->diag("Diag Message"); + +Generate a diagniostics (stderr) message + +=item L<Test::Stream::Event::Note> + + $ctx->note("Note Message"); + +Generate a note (stdout) message + +=item L<Test::Stream::Event::Bail> + + $ctx->bail("Reason we are bailing"); + +Stop the entire test file, something is very wrong! + +=item L<Test::Stream::Event::Plan> + + $ctx->plan($max); + $ctx->plan(0, $directive, $reason); + +Set the plan. + +=back + +=head1 Testing your tools + +See L<Test::Stream::Tester>, which lets you intercept and validate events. + +B<DO NOT SEE> C<Test::Tester> and C<Test::Builder::Tester> which are both +deprecated. They were once the way everyone tested their testers, but they do +not allow you to test all events, and they are very fragile when upstream libs +change. + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm new file mode 100644 index 0000000000..f354fda602 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/use/ok.pm @@ -0,0 +1,152 @@ +package Test::use::ok; +use strict; +use warnings; +use 5.005; + +our $VERSION = '1.301001_071'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Stream 1.301001 '-internal'; + +1; +__END__ + +=encoding utf8 + +=head1 NAME + +Test::use::ok - Alternative to Test::More::use_ok + +=head1 SYNOPSIS + + use ok 'Some::Module'; + +=head1 DESCRIPTION + +According to the B<Test::More> documentation, it used to be recommended to run +C<use_ok()> inside a C<BEGIN> 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<BEGIN>, or mistakenly group +C<use_ok> with other tests in a single C<BEGIN> block, which can create subtle +differences in execution order. + +With this module, simply change all C<use_ok> in test scripts to C<use ok>, +and they will be executed at C<BEGIN> time. The explicit space after C<use> +makes it clear that this is a single compile-time action. + +=head1 SEE ALSO + +L<Test::More> + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt> + +=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt> + +=item Michael G Schwern E<lt>schwern@pobox.comE<gt> + +=item 唐鳳 + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> 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. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back + +=cut |