diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Test')
62 files changed, 14171 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm new file mode 100755 index 00000000000..26ffea41ff4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder.pm @@ -0,0 +1,2501 @@ +package Test::Builder; + +use 5.006; +use strict; +use warnings; + +our $VERSION = '0.94'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +BEGIN { + if( $] < 5.008 ) { + require Test::Builder::IO::Scalar; + } +} + + +# 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 + # occassionally 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 }; + } +} + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use base 'Test::Builder::Module'; + + my $CLASS = __PACKAGE__; + + sub ok { + my($test, $name) = @_; + my $tb = $CLASS->builder; + + $tb->ok($test, $name); + } + + +=head1 DESCRIPTION + +Test::Simple and Test::More have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides the a +building block upon which to write your own test libraries I<which can +work together>. + +=head2 Construction + +=over 4 + +=item B<new> + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program C<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. + +If you want a completely new Test::Builder object different from the +singleton, use C<create>. + +=cut + +our $Test = Test::Builder->new; + +sub new { + my($class) = shift; + $Test ||= $class->create; + 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 $self = bless {}, $class; + $self->reset; + + return $self; +} + +=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 +indented four spaces more than the parent's indentation. When done, the +C<finalize> method I<must> be called explicitly. + +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 child { + my( $self, $name ) = @_; + + if( $self->{Child_Name} ) { + $self->croak("You already have a child named ($self->{Child_Name}) running"); + } + + my $child = bless {}, ref $self; + $child->reset; + + # Add to our indentation + $child->_indent( $self->_indent . ' ' ); + $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH}; + + # 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->{Name} = $name || "Child of " . $self->name; + $self->{Child_Name} = $child->name; + return $child; +} + + +=item B<subtest> + + $builder->subtest($name, \&subtests); + +See documentation of C<subtest> in Test::More. + +=cut + +sub subtest { + my $self = shift; + my($name, $subtests) = @_; + + if ('CODE' ne ref $subtests) { + $self->croak("subtest()'s second argument must be a code ref"); + } + + # Turn the child into the parent so anyone who has stored a copy of + # the Test::Builder singleton will get the child. + my $child = $self->child($name); + my %parent = %$self; + %$self = %$child; + + my $error; + if( !eval { $subtests->(); 1 } ) { + $error = $@; + } + + # Restore the parent and the copied child. + %$child = %$self; + %$self = %parent; + + # Die *after* we restore the parent. + die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; + + return $child->finalize; +} + + +=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 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 { + my $self = shift; + + return unless $self->parent; + if( $self->{Child_Name} ) { + $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); + } + $self->_ending; + + # XXX This will only be necessary for TAP envelopes (we think) + #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + + my $ok = 1; + $self->parent->{Child_Name} = undef; + if ( $self->{Skip_All} ) { + $self->parent->skip($self->{Skip_All}); + } + 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 ); + } + $? = $self->{Child_Error}; + delete $self->{Parent}; + + return $self->is_passing; +} + +sub _indent { + my $self = shift; + + if( @_ ) { + $self->{Indent} = shift; + } + + return $self->{Indent}; +} + +=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; + +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". + +=cut + +sub name { shift->{Name} } + +sub DESTROY { + my $self = shift; + if ( $self->parent ) { + my $name = $self->name; + $self->diag(<<"FAIL"); +Child ($name) exited without calling finalize() +FAIL + $self->parent->{In_Destroy} = 1; + $self->parent->ok(0, $name); + } +} + +=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->{Original_Pid} = $$; + $self->{Child_Name} = undef; + $self->{Indent} ||= ''; + + share( $self->{Curr_Test} ); + $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; + + $self->_dup_stdhandles; + + return; +} + +=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 you call C<plan()>, don't call any of the other methods below. + +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. + + 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 + +my %plan_cmds = ( + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, +); + +sub plan { + my( $self, $cmd, $arg ) = @_; + + return unless $cmd; + + local $Level = $Level + 1; + + $self->croak("You tried to plan twice") if $self->{Have_Plan}; + + if( my $method = $plan_cmds{$cmd} ) { + local $Level = $Level + 1; + $self->$method($arg); + } + else { + my @args = grep { defined } ( $cmd, $arg ); + $self->croak("plan() doesn't understand @args"); + } + + return 1; +} + + +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->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; + + $self->_output_plan($max) unless $self->no_header; + } + return $self->{Expected_Tests}; +} + +=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) = @_; + + $self->carp("no_plan takes no arguments") if $arg; + + $self->{No_Plan} = 1; + $self->{Have_Plan} = 1; + + 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(@tests); + +=cut + +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( $self->{Done_Testing} ) { + my($file, $line) = @{$self->{Done_Testing}}[1,2]; + $self->ok(0, "done_testing() was already called at $file line $line"); + return; + } + + $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"); + } + else { + $self->{Expected_Tests} = $num_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; +} + + +=item B<has_plan> + + $plan = $Test->has_plan + +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). + +=cut + +sub has_plan { + my $self = shift; + + 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); + +Skips all the tests, using the given C<$reason>. Exits immediately with 0. + +=cut + +sub skip_all { + 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); +} + +=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 ) = @_; + + if( defined $pack ) { + $self->{Exported_To} = $pack; + } + return $self->{Exported_To}; +} + +=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} = ''; + } + + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; + $out .= "\n"; + + $self->_print($out); + + unless($test) { + my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; + $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; + + 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]); + } + } + + $self->is_passing(0) unless $test || $self->in_todo; + + # Check that we haven't violated the plan + $self->_check_is_passing_plan(); + + return $test ? 1 : 0; +} + + +# Check that we haven't yet violated the plan and set +# is_passing() accordingly +sub _check_is_passing_plan { + 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}; +} + + +sub _unoverload { + 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; +} + +sub _is_object { + my( $self, $thing ) = @_; + + return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; +} + +sub _unoverload_str { + my $self = shift; + + return $self->_unoverload( q[""], @_ ); +} + +sub _unoverload_num { + my $self = shift; + + $self->_unoverload( '0+', @_ ); + + for my $val (@_) { + next unless $self->_is_dualvar($$val); + $$val = $$val + 0; + } + + 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> + + $Test->is_eq($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the +string version. + +=item B<is_num> + + $Test->is_num($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the +numeric version. + +=cut + +sub is_eq { + my( $self, $got, $expect, $name ) = @_; + local $Level = $Level + 1; + + $self->_unoverload_str( \$got, \$expect ); + + 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 ); +} + +sub is_num { + my( $self, $got, $expect, $name ) = @_; + local $Level = $Level + 1; + + $self->_unoverload_num( \$got, \$expect ); + + 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 +} + +=item B<isnt_eq> + + $Test->isnt_eq($got, $dont_expect, $name); + +Like 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 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 ); +} + +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 ); +} + +=item B<like> + + $Test->like($this, qr/$regex/, $name); + $Test->like($this, '/$regex/', $name); + +Like Test::More's C<like()>. Checks if $this matches the given C<$regex>. + +=item B<unlike> + + $Test->unlike($this, qr/$regex/, $name); + $Test->unlike($this, '/$regex/', $name); + +Like Test::More's C<unlike()>. Checks if $this B<does not match> the +given C<$regex>. + +=cut + +sub like { + my( $self, $this, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $this, $regex, '=~', $name ); +} + +sub unlike { + my( $self, $this, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $this, $regex, '!~', $name ); +} + +=item B<cmp_ok> + + $Test->cmp_ok($this, $type, $that, $name); + +Works just like Test::More's C<cmp_ok()>. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=cut + +my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); + +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + + my $test; + my $error; + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + my($pack, $file, $line) = $self->caller(); + + $test = eval qq[ +#line 1 "cmp_ok [from $file line $line]" +\$got $type \$expect; +]; + $error = $@; + } + local $Level = $Level + 1; + my $ok = $self->ok( $test, $name ); + + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload + = $numeric_cmps{$type} + ? '_unoverload_num' + : '_unoverload_str'; + + $self->diag(<<"END") if $error; +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 ); + } + } + 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 +} + +sub _caller_context { + my $self = shift; + + my( $pack, $file, $line ) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + return $code; +} + +=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 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; + $self->_print("Bail out! $reason"); + exit 255; +} + +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=cut + +{ + no warnings 'once'; + *BAILOUT = \&BAIL_OUT; +} + +=item B<skip> + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=cut + +sub skip { + my( $self, $why ) = @_; + $why ||= ''; + $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 => '', + 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; +} + +=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; +} + +=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, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ 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 _is_qr { + my $regex = shift; + + # is_regexp() checks for regexes in a robust manner, say if they're + # blessed. + return re::is_regexp($regex) if defined &re::is_regexp; + return ref $regex eq 'Regexp'; +} + +sub _regex_ok { + my( $self, $this, $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; + } + + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + my $test; + my $context = $self->_caller_context; + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; + + $test = !$test if $cmp eq '!~'; + + local $Level = $Level + 1; + $ok = $self->ok( $test, $name ); + } + + unless($ok) { + $this = defined $this ? "'$this'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + + local $Level = $Level + 1; + $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); + %s + %13s '%s' +DIAGNOSTIC + + } + + return $ok; +} + +# 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; +} + +=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; + return 0 unless defined $maybe_fh; + + return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return eval { $maybe_fh->isa("IO::Handle") } || + eval { tied($maybe_fh)->can('TIEHANDLE') }; +} + +=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}; + }; + + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; +} + +=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(...); + +=for blame transfer +Mark Fowler <mark@twoshortplanks.com> + +=cut + +sub diag { + my $self = shift; + + $self->_print_comment( $self->_diag_fh, @_ ); +} + +=item B<note> + + $Test->note(@msgs); + +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, @_ ); +} + +sub _diag_fh { + 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; + + # Escape the beginning, _print will take care of the rest. + $msg =~ s/^/# /; + + local $Level = $Level + 1; + $self->_print_to_fh( $fh, $msg ); + + return 0; +} + +=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; + } + : $_ + } @_; +} + +=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 _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; + + local( $\, $", $, ) = ( undef, ' ', '' ); + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + $msg =~ s{\n(?!\z)}{\n# }sg; + + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\z/; + + return print $fh $self->_indent, $msg; +} + +=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}; +} + +sub failure_output { + my( $self, $fh ) = @_; + + if( defined $fh ) { + $self->{Fail_FH} = $self->_new_fh($fh); + } + return $self->{Fail_FH}; +} + +sub todo_output { + my( $self, $fh ) = @_; + + if( defined $fh ) { + $self->{Todo_FH} = $self->_new_fh($fh); + } + return $self->{Todo_FH}; +} + +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; + + my $fh; + if( $self->is_fh($file_or_fh) ) { + $fh = $file_or_fh; + } + elsif( ref $file_or_fh eq 'SCALAR' ) { + # Scalar refs as filehandles was added in 5.8. + if( $] >= 5.008 ) { + open $fh, ">>", $file_or_fh + or $self->croak("Can't open scalar ref $file_or_fh: $!"); + } + # Emulate scalar ref filehandles with a tie. + else { + $fh = Test::Builder::IO::Scalar->new($file_or_fh) + or $self->croak("Can't tie scalar ref $file_or_fh"); + } + } + else { + open $fh, ">", $file_or_fh + or $self->croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); + } + + return $fh; +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; +} + +my( $Testout, $Testerr ); + +sub _dup_stdhandles { + 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; +} + +sub _open_testhandles { + my $self = shift; + + return if $self->{Opened_Testhandles}; + + # 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: $!"; + + # $self->_copy_io_layers( \*STDOUT, $Testout ); + # $self->_copy_io_layers( \*STDERR, $Testerr ); + + $self->{Opened_Testhandles} = 1; + + return; +} + +sub _copy_io_layers { + my( $self, $src, $dst ) = @_; + + $self->_try( + sub { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); + + binmode $dst, join " ", map ":$_", @src_layers if @src_layers; + } + ); + + return; +} + +=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; +} + +=item carp + + $tb->carp(@message); + +Warns with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + +=item croak + + $tb->croak(@message); + +Dies with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + +=cut + +sub _message_at_caller { + my $self = shift; + + local $Level = $Level + 1; + my( $pack, $file, $line ) = $self->caller; + return join( "", @_ ) . " at $file line $line.\n"; +} + +sub carp { + my $self = shift; + return warn $self->_message_at_caller(@_); +} + +sub croak { + my $self = shift; + return die $self->_message_at_caller(@_); +} + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B<current_test> + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test number we're on. You usually shouldn't +have to set this. + +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. + +=cut + +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}; +} + +=item B<is_passing> + + my $ok = $builder->is_passing; + +Indicates if the test suite is currently passing. + +More formally, it will be false if anything has happened which makes +it impossible for the test suite to pass. True otherwise. + +For example, if no tests have run C<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. + +Don't think about it too much. + +=cut + +sub is_passing { + my $self = shift; + + if( @_ ) { + $self->{Is_Passing} = shift; + } + + return $self->{Is_Passing}; +} + + +=item B<summary> + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + +=cut + +sub summary { + my($self) = shift; + + return map { $_->{'ok'} } @{ $self->{Test_Results} }; +} + +=item B<details> + + my @tests = $Test->details; + +Like C<summary()>, but with a lot more detail. + + $tests[$test_num - 1] = + { 'ok' => is the test considered a pass? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => type of test (if any, see below). + reason => reason for the above (if any) + }; + +'ok' is true if Test::Harness will consider the test to be a pass. + +'actual_ok' is a reflection of whether or not the test literally +printed 'ok' or 'not ok'. This is for examining the result of 'todo' +tests. + +'name' is the name of the test. + +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: + + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below + +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when C<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>. + +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: + + $tests[22] = # 23 - 1, since arrays start from 0. + { ok => 1, # logically, the test passed since its todo + actual_ok => 0, # in absolute terms, it failed + name => 'hole count', + type => 'todo', + reason => 'insufficient donuts' + }; + +=cut + +sub details { + my $self = shift; + return @{ $self->{Test_Results} }; +} + +=item B<todo> + + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); + +If the current tests are considered "TODO" it will return the reason, +if any. This reason can come from a C<$TODO> variable or the last call +to C<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. + +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()>. + +Sometimes there is some confusion about where todo() should be looking +for the C<$TODO> variable. If you want to be sure, tell it explicitly +what $pack to use. + +=cut + +sub todo { + my( $self, $pack ) = @_; + + return $self->{Todo} if defined $self->{Todo}; + + local $Level = $Level + 1; + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; + + return ''; +} + +=item B<find_TODO> + + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack): + +Like C<todo()> but only returns the value of C<$TODO> ignoring +C<todo_start()>. + +=cut + +sub find_TODO { + my( $self, $pack ) = @_; + + $pack = $pack || $self->caller(1) || $self->exported_to; + return unless $pack; + + no strict 'refs'; ## no critic + return ${ $pack . '::TODO' }; +} + +=item B<in_todo> + + my $in_todo = $Test->in_todo; + +Returns true if the test is currently inside a TODO block. + +=cut + +sub in_todo { + my $self = shift; + + local $Level = $Level + 1; + return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; +} + +=item B<todo_start> + + $Test->todo_start(); + $Test->todo_start($message); + +This method allows you declare all subsequent tests as TODO tests, up until +the C<todo_end> method has been called. + +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). + +Note that you can use this to nest "todo" tests + + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + +This is generally not recommended, but large testing systems often have weird +internal needs. + +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: + + TODO: { + local $TODO = 'We have work to do!'; + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + } + +Pick one style or another of "TODO" to be on the safe side. + +=cut + +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; + + $self->{Start_Todo}++; + if( $self->in_todo ) { + push @{ $self->{Todo_Stack} } => $self->todo; + } + $self->{Todo} = $message; + + return; +} + +=item C<todo_end> + + $Test->todo_end; + +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C<todo_start> method call. + +=cut + +sub todo_end { + my $self = shift; + + if( !$self->{Start_Todo} ) { + $self->croak('todo_end() called without todo_start()'); + } + + $self->{Start_Todo}--; + + if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { + $self->{Todo} = pop @{ $self->{Todo_Stack} }; + } + else { + delete $self->{Todo}; + } + + return; +} + +=item B<caller> + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal C<caller()>, except it reports according to your C<level()>. + +C<$height> will be added to the C<level()>. + +If C<caller()> winds up off the top of the stack it report the highest context. + +=cut + +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]; +} + +=back + +=cut + +=begin _private + +=over 4 + +=item B<_sanity_check> + + $self->_sanity_check(); + +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. + +=cut + +#'# +sub _sanity_check { + my $self = shift; + + $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!' ); + + return; +} + +=item B<_whoa> + + $self->_whoa($check, $description); + +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. + +=cut + +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 + } + + return; +} + +=item B<_my_exit> + + _my_exit($exit_num); + +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. + +=cut + +sub _my_exit { + $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) + + return 1; +} + +=back + +=end _private + +=cut + +sub _ending { + my $self = shift; + return if $self->no_ending; + return if $self->{Ending}++; + + my $real_exit_code = $?; + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + if( $self->{Original_Pid} != $$ ) { + return; + } + + # 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."); + } + + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + if( !$self->{Have_Plan} ) { + return; + } + + # 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}; + } + + # 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]; + } + + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; + + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; + + 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); + } + + if($num_failed) { + my $num_tests = $self->{Curr_Test}; + my $s = $num_failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + + $self->diag(<<"FAIL"); +Looks like you failed $num_failed test$s of $num_tests$qualifier. +FAIL + $self->is_passing(0); + } + + 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; + } + + 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; + } + + _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; + } + + $self->is_passing(0); + $self->_whoa( 1, "We fell off the end of _ending()" ); +} + +END { + $Test->_ending if defined $Test; +} + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +=head1 THREADS + +In perl 5.8.1 and later, Test::Builder is thread-safe. The test +number is shared amongst all threads. This means if one thread sets +the test number using C<current_test()> they will all be effected. + +While versions earlier than 5.8.1 had threads they contain too many +bugs to support. + +Test::Builder is only thread-aware if threads.pm is loaded I<before> +Test::Builder. + +=head1 MEMORY + +An informative hash, accessable 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. + +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 fail() should anything go unexpected. + +Future versions of Test::Builder will have a way to turn history off. + + +=head1 EXAMPLES + +CPAN can provide the best examples. Test::Simple, Test::More, +Test::Exception and Test::Differences all use Test::Builder. + +=head1 SEE ALSO + +Test::Simple, Test::More, Test::Harness + +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +E<lt>schwern@pobox.comE<gt> + +=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/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm new file mode 100755 index 00000000000..b8ca7207dbb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/IO/Scalar.pm @@ -0,0 +1,658 @@ +package Test::Builder::IO::Scalar; + + +=head1 NAME + +Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder + +=head1 DESCRIPTION + +This is a copy of IO::Scalar which ships with Test::Builder to +support scalar references as filehandles on Perl 5.6. Newer +versions of Perl simply use C<<open()>>'s built in support. + +Test::Builder can not have dependencies on other modules without +careful consideration, so its simply been copied into the distribution. + +=head1 COPYRIGHT and LICENSE + +This file came from the "IO-stringy" Perl5 toolkit. + +Copyright (c) 1996 by Eryq. All rights reserved. +Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=cut + +# This is copied code, I don't care. +##no critic + +use Carp; +use strict; +use vars qw($VERSION @ISA); +use IO::Handle; + +use 5.005; + +### The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +### Inheritance: +@ISA = qw(IO::Handle); + +#============================== + +=head2 Construction + +=over 4 + +=cut + +#------------------------------ + +=item new [ARGS...] + +I<Class method.> +Return a new, unattached scalar handle. +If any arguments are given, they're sent to open(). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless \do { local *FH }, $class; + tie *$self, $class, $self; + $self->open(@_); ### open on anonymous by default + $self; +} +sub DESTROY { + shift->close; +} + +#------------------------------ + +=item open [SCALARREF] + +I<Instance method.> +Open the scalar handle on a new scalar, pointed to by SCALARREF. +If no SCALARREF is given, a "private" scalar is created to hold +the file data. + +Returns the self object on success, undefined on error. + +=cut + +sub open { + my ($self, $sref) = @_; + + ### Sanity: + defined($sref) or do {my $s = ''; $sref = \$s}; + (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; + + ### Setup: + *$self->{Pos} = 0; ### seek position + *$self->{SR} = $sref; ### scalar reference + $self; +} + +#------------------------------ + +=item opened + +I<Instance method.> +Is the scalar handle opened on something? + +=cut + +sub opened { + *{shift()}->{SR}; +} + +#------------------------------ + +=item close + +I<Instance method.> +Disassociate the scalar handle from its underlying scalar. +Done automatically on destroy. + +=cut + +sub close { + my $self = shift; + %{*$self} = (); + 1; +} + +=back + +=cut + + + +#============================== + +=head2 Input and output + +=over 4 + +=cut + + +#------------------------------ + +=item flush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub flush { "0 but true" } + +#------------------------------ + +=item getc + +I<Instance method.> +Return the next character, or undef if none remain. + +=cut + +sub getc { + my $self = shift; + + ### Return undef right away if at EOF; else, move pos forward: + return undef if $self->eof; + substr(${*$self->{SR}}, *$self->{Pos}++, 1); +} + +#------------------------------ + +=item getline + +I<Instance method.> +Return the next line, or undef on end of string. +Can safely be called in an array context. +Currently, lines are delimited by "\n". + +=cut + +sub getline { + my $self = shift; + + ### Return undef right away if at EOF: + return undef if $self->eof; + + ### Get next line: + my $sr = *$self->{SR}; + my $i = *$self->{Pos}; ### Start matching at this point. + + ### Minimal impact implementation! + ### We do the fast fast thing (no regexps) if using the + ### classic input record separator. + + ### Case 1: $/ is undef: slurp all... + if (!defined($/)) { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + + ### Case 2: $/ is "\n": zoom zoom zoom... + elsif ($/ eq "\012") { + + ### Seek ahead for "\n"... yes, this really is faster than regexps. + my $len = length($$sr); + for (; $i < $len; ++$i) { + last if ord (substr ($$sr, $i, 1)) == 10; + } + + ### Extract the line: + my $line; + if ($i < $len) { ### We found a "\n": + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); + *$self->{Pos} = $i+1; ### Remember where we finished up. + } + else { ### No "\n"; slurp the remainder: + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); + *$self->{Pos} = $len; + } + return $line; + } + + ### Case 3: $/ is ref to int. Do fixed-size records. + ### (Thanks to Dominique Quatravaux.) + elsif (ref($/)) { + my $len = length($$sr); + my $i = ${$/} + 0; + my $line = substr ($$sr, *$self->{Pos}, $i); + *$self->{Pos} += $i; + *$self->{Pos} = $len if (*$self->{Pos} > $len); + return $line; + } + + ### Case 4: $/ is either "" (paragraphs) or something weird... + ### This is Graham's general-purpose stuff, which might be + ### a tad slower than Case 2 for typical data, because + ### of the regexps. + else { + pos($$sr) = $i; + + ### If in paragraph mode, skip leading lines (and update i!): + length($/) or + (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); + + ### If we see the separator in the buffer ahead... + if (length($/) + ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! + : $$sr =~ m,\n\n,g ### (a paragraph) + ) { + *$self->{Pos} = pos $$sr; + return substr($$sr, $i, *$self->{Pos}-$i); + } + ### Else if no separator remains, just slurp the rest: + else { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + } +} + +#------------------------------ + +=item getlines + +I<Instance method.> +Get all remaining lines. +It will croak() if accidentally called in a scalar context. + +=cut + +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + my ($line, @lines); + push @lines, $line while (defined($line = $self->getline)); + @lines; +} + +#------------------------------ + +=item print ARGS... + +I<Instance method.> +Print ARGS to the underlying scalar. + +B<Warning:> this continues to always cause a seek to the end +of the string, but if you perform seek()s and tell()s, it is +still safer to explicitly seek-to-end before subsequent print()s. + +=cut + +sub print { + my $self = shift; + *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); + 1; +} +sub _unsafe_print { + my $self = shift; + my $append = join('', @_) . $\; + ${*$self->{SR}} .= $append; + *$self->{Pos} += length($append); + 1; +} +sub _old_print { + my $self = shift; + ${*$self->{SR}} .= join('', @_) . $\; + *$self->{Pos} = length(${*$self->{SR}}); + 1; +} + + +#------------------------------ + +=item read BUF, NBYTES, [OFFSET] + +I<Instance method.> +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub read { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); + $n = length($read); + *$self->{Pos} += $n; + ($off ? substr($_[1], $off) : $_[1]) = $read; + return $n; +} + +#------------------------------ + +=item write BUF, NBYTES, [OFFSET] + +I<Instance method.> +Write some bytes to the scalar. + +=cut + +sub write { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $data = substr($_[1], $off, $n); + $n = length($data); + $self->print($data); + return $n; +} + +#------------------------------ + +=item sysread BUF, LEN, [OFFSET] + +I<Instance method.> +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub sysread { + my $self = shift; + $self->read(@_); +} + +#------------------------------ + +=item syswrite BUF, NBYTES, [OFFSET] + +I<Instance method.> +Write some bytes to the scalar. + +=cut + +sub syswrite { + my $self = shift; + $self->write(@_); +} + +=back + +=cut + + +#============================== + +=head2 Seeking/telling and other attributes + +=over 4 + +=cut + + +#------------------------------ + +=item autoflush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub autoflush {} + +#------------------------------ + +=item binmode + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub binmode {} + +#------------------------------ + +=item clearerr + +I<Instance method.> Clear the error and EOF flags. A no-op. + +=cut + +sub clearerr { 1 } + +#------------------------------ + +=item eof + +I<Instance method.> Are we at end of file? + +=cut + +sub eof { + my $self = shift; + (*$self->{Pos} >= length(${*$self->{SR}})); +} + +#------------------------------ + +=item seek OFFSET, WHENCE + +I<Instance method.> Seek to a given position in the stream. + +=cut + +sub seek { + my ($self, $pos, $whence) = @_; + my $eofpos = length(${*$self->{SR}}); + + ### Seek: + if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET + elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR + elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END + else { croak "bad seek whence ($whence)" } + + ### Fixup: + if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } + if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } + return 1; +} + +#------------------------------ + +=item sysseek OFFSET, WHENCE + +I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> + +=cut + +sub sysseek { + my $self = shift; + $self->seek (@_); +} + +#------------------------------ + +=item tell + +I<Instance method.> +Return the current position in the stream, as a numeric offset. + +=cut + +sub tell { *{shift()}->{Pos} } + +#------------------------------ + +=item use_RS [YESNO] + +I<Instance method.> +B<Deprecated and ignored.> +Obey the curent setting of $/, like IO::Handle does? +Default is false in 1.x, but cold-welded true in 2.x and later. + +=cut + +sub use_RS { + my ($self, $yesno) = @_; + carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; + } + +#------------------------------ + +=item setpos POS + +I<Instance method.> +Set the current position, using the opaque value returned by C<getpos()>. + +=cut + +sub setpos { shift->seek($_[0],0) } + +#------------------------------ + +=item getpos + +I<Instance method.> +Return the current position in the string, as an opaque object. + +=cut + +*getpos = \&tell; + + +#------------------------------ + +=item sref + +I<Instance method.> +Return a reference to the underlying scalar. + +=cut + +sub sref { *{shift()}->{SR} } + + +#------------------------------ +# Tied handle methods... +#------------------------------ + +# Conventional tiehandle interface: +sub TIEHANDLE { + ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) + ? $_[1] + : shift->new(@_)); +} +sub GETC { shift->getc(@_) } +sub PRINT { shift->print(@_) } +sub PRINTF { shift->print(sprintf(shift, @_)) } +sub READ { shift->read(@_) } +sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } +sub WRITE { shift->write(@_); } +sub CLOSE { shift->close(@_); } +sub SEEK { shift->seek(@_); } +sub TELL { shift->tell(@_); } +sub EOF { shift->eof(@_); } + +#------------------------------------------------------------ + +1; + +__END__ + + + +=back + +=cut + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C<seek()>, C<tell()>, and C<eof()>. +Attempting to use these functions with an IO::Scalar will not work +prior to 5.005_57. IO::Scalar will not have the relevant methods +invoked; and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C<perl -w>), +and you see something like this... + + attempt to seek on unopened filehandle + +...then you are probably trying to use one of these functions +on an IO::Scalar with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + +=head1 VERSION + +$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHORS + +=head2 Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=head2 Principal author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + + +=head2 Other contributors + +The full set of contributors always includes the folks mentioned +in L<IO::Stringy/"CHANGE LOG">. But just the same, special +thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I<Andy Glew,> +for contributing C<getc()>. + +I<Brandon Browning,> +for suggesting C<opened()>. + +I<David Richter,> +for finding and fixing the bug in C<PRINTF()>. + +I<Eric L. Brine,> +for his offset-using read() and write() implementations. + +I<Richard Jones,> +for his patches to massively improve the performance of C<getline()> +and add C<sysread> and C<syswrite>. + +I<B. K. Oxley (binkley),> +for stringification and inheritance improvements, +and sundry good ideas. + +I<Doug Wilson,> +for the IO::Handle inheritance and automatic tie-ing. + + +=head1 SEE ALSO + +L<IO::String>, which is quite similar but which was designed +more-recently and with an IO::Handle-like interface in mind, +so you could mix OO- and native-filehandle usage without using tied(). + +I<Note:> as of version 2.x, these classes all work like +their IO::Handle counterparts, so we have comparable +functionality to IO::String. + +=cut + diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm new file mode 100755 index 00000000000..4f7d1aa7db7 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Module.pm @@ -0,0 +1,173 @@ +package Test::Builder::Module; + +use strict; + +use Test::Builder; + +require Exporter; +our @ISA = qw(Exporter); + +our $VERSION = '0.94'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + + +=head1 NAME + +Test::Builder::Module - Base class for test modules + +=head1 SYNOPSIS + + # Emulates Test::Simple + package Your::Module; + + my $CLASS = __PACKAGE__; + + use base 'Test::Builder::Module'; + @EXPORT = qw(ok); + + sub ok ($;$) { + my $tb = $CLASS->builder; + return $tb->ok(@_); + } + + 1; + + +=head1 DESCRIPTION + +This is a superclass for Test::Builder-based modules. It provides a +handful of common functionality and a method of getting at the underlying +Test::Builder object. + + +=head2 Importing + +Test::Builder::Module is a subclass of Exporter which means your +module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... +all act normally. + +A few methods are provided to do the C<use Your::Module tests => 23> part +for you. + +=head3 import + +Test::Builder::Module provides an import() method which acts in the +same basic way as Test::More's, setting the plan and controling +exporting of functions and variables. This allows your module to set +the plan independent of Test::More. + +All arguments passed to 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; + +says to import the functions this() and that() as well as set the plan +to be 23 tests. + +import() also sets the exported_to() attribute of your builder to be +the caller of the import() function. + +Additional behaviors can be added to your import() method by overriding +import_extra(). + +=cut + +sub import { + my($class) = shift; + + # Don't run all this when loading ourself. + return 1 if $class eq 'Test::Builder::Module'; + + my $test = $class->builder; + + my $caller = caller; + + $test->exported_to($caller); + + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); + + $test->plan(@_); + + $class->export_to_level( 1, $class, @imports ); +} + +sub _strip_imports { + my $class = shift; + my $list = shift; + + my @imports = (); + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'import' ) { + push @imports, @{ $list->[ $idx + 1 ] }; + $idx++; + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + return @imports; +} + +=head3 import_extra + + Your::Module->import_extra(\@import_args); + +import_extra() is called by import(). It provides an opportunity for you +to add behaviors to your module based on its import list. + +Any extra arguments which shouldn't be passed on to plan() should be +stripped off by this method. + +See Test::More for an example of its use. + +B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it +feels like a bit of an ugly hack in its current form. + +=cut + +sub import_extra { } + +=head2 Builder + +Test::Builder::Module provides some methods of getting at the underlying +Test::Builder object. + +=head3 builder + + my $builder = Your::Class->builder; + +This method returns the Test::Builder object associated with Your::Class. +It is not a constructor so you can call it as often as you like. + +This is the preferred way to get the Test::Builder object. You should +I<not> get it via C<< Test::Builder->new >> as was previously +recommended. + +The object returned by builder() may change at runtime so you should +call builder() inside each function rather than store it in a global. + + sub ok { + my $builder = Your::Class->builder; + + return $builder->ok(@_); + } + + +=cut + +sub builder { + return Test::Builder->new; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm new file mode 100755 index 00000000000..7bea6f99da6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester.pm @@ -0,0 +1,603 @@ +package Test::Builder::Tester; + +use strict; +our $VERSION = "1.18"; + +use Test::Builder; +use Symbol; +use Carp; + +=head1 NAME + +Test::Builder::Tester - test testsuites that have been built with +Test::Builder + +=head1 SYNOPSIS + + use Test::Builder::Tester tests => 1; + use Test::More; + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=head1 DESCRIPTION + +A module that helps you test testing modules that are built with +B<Test::Builder>. + +The testing system is designed to be used by performing a three step +process for each test you wish to test. This process starts with using +C<test_out> and C<test_err> in advance to declare what the testsuite you +are testing will output with B<Test::Builder> to stdout and stderr. + +You then can run the test(s) from your test suite that call +B<Test::Builder>. At this point the output of B<Test::Builder> is +safely captured by B<Test::Builder::Tester> rather than being +interpreted as real test output. + +The final stage is to call C<test_test> that will simply compare what you +predeclared to what B<Test::Builder> actually outputted, and report the +results back with a "ok" or "not ok" (with debugging) to the normal +output. + +=cut + +#### +# set up testing +#### + +my $t = Test::Builder->new; + +### +# make us an exporter +### + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); + +sub import { + my $class = shift; + my(@plan) = @_; + + my $caller = caller; + + $t->exported_to($caller); + $t->plan(@plan); + + my @imports = (); + foreach my $idx ( 0 .. $#plan ) { + if( $plan[$idx] eq 'import' ) { + @imports = @{ $plan[ $idx + 1 ] }; + last; + } + } + + __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); +} + +### +# set up file handles +### + +# create some private file handles +my $output_handle = gensym; +my $error_handle = gensym; + +# and tie them to this package +my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; +my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; + +#### +# exported functions +#### + +# for remembering that we're testing and where we're testing at +my $testing = 0; +my $testing_num; + +# remembering where the file handles were originally connected +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; + +my $original_test_number; +my $original_harness_state; + +my $original_harness_env; + +# function that starts testing and redirects the filehandles for now +sub _start_testing { + # even if we're running under Test::Harness pretend we're not + # for now. This needed so Test::Builder doesn't add extra spaces + $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; + $ENV{HARNESS_ACTIVE} = 0; + + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing = 1; + $testing_num = $t->current_test; + $t->current_test(0); + + # look, we shouldn't do the ending stuff + $t->no_ending(1); +} + +=head2 Functions + +These are the six methods that are exported as default. + +=over 4 + +=item test_out + +=item test_err + +Procedures for predeclaring the output that your test suite is +expected to produce until C<test_test> is called. These procedures +automatically assume that each line terminates with "\n". So + + test_out("ok 1","ok 2"); + +is the same as + + test_out("ok 1\nok 2"); + +which is even the same as + + test_out("ok 1"); + test_out("ok 2"); + +Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have +been called once all further output from B<Test::Builder> will be +captured by B<Test::Builder::Tester>. This means that your will not +be able perform further tests to the normal output in the normal way +until you call C<test_test> (well, unless you manually meddle with the +output filehandles) + +=cut + +sub test_out { + # do we need to do any setup? + _start_testing() unless $testing; + + $out->expect(@_); +} + +sub test_err { + # do we need to do any setup? + _start_testing() unless $testing; + + $err->expect(@_); +} + +=item test_fail + +Because the standard failure message that B<Test::Builder> produces +whenever a test fails will be a common occurrence in your test error +output, and because has changed between Test::Builder versions, rather +than forcing you to call C<test_err> with the string all the time like +so + + test_err("# Failed test ($0 at line ".line_num(+1).")"); + +C<test_fail> exists as a convenience function that can be called +instead. It takes one argument, the offset from the current line that +the line that causes the fail is on. + + test_fail(+1); + +This means that the example in the synopsis could be rewritten +more simply as: + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=cut + +sub test_fail { + # do we need to do any setup? + _start_testing() unless $testing; + + # work out what line we should be on + my( $package, $filename, $line ) = caller; + $line = $line + ( shift() || 0 ); # prevent warnings + + # expect that on stderr + $err->expect("# Failed test ($0 at line $line)"); +} + +=item test_diag + +As most of the remaining expected output to the error stream will be +created by Test::Builder's C<diag> function, B<Test::Builder::Tester> +provides a convience function C<test_diag> that you can use instead of +C<test_err>. + +The C<test_diag> function prepends comment hashes and spacing to the +start and newlines to the end of the expected output passed to it and +adds it to the list of expected error output. So, instead of writing + + test_err("# Couldn't open file"); + +you can write + + test_diag("Couldn't open file"); + +Remember that B<Test::Builder>'s diag function will not add newlines to +the end of output and test_diag will. So to check + + Test::Builder->new->diag("foo\n","bar\n"); + +You would do + + test_diag("foo","bar") + +without the newlines. + +=cut + +sub test_diag { + # do we need to do any setup? + _start_testing() unless $testing; + + # expect the same thing, but prepended with "# " + local $_; + $err->expect( map { "# $_" } @_ ); +} + +=item test_test + +Actually performs the output check testing the tests, comparing the +data (with C<eq>) that we have captured from B<Test::Builder> against +that that was declared with C<test_out> and C<test_err>. + +This takes name/value pairs that effect how the test is run. + +=over + +=item title (synonym 'name', 'label') + +The name of the test that will be displayed after the C<ok> or C<not +ok>. + +=item skip_out + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the output stream does not match that +declared with C<test_out>. + +=item skip_err + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the error stream does not match that +declared with C<test_err>. + +=back + +As a convience, if only one argument is passed then this argument +is assumed to be the name of the test (as in the above examples.) + +Once C<test_test> has been run test output will be redirected back to +the original filehandles that B<Test::Builder> was connected to +(probably STDOUT and STDERR,) meaning any further tests you run +will function normally and cause success/errors for B<Test::Harness>. + +=cut + +sub test_test { + # decode the arguements as described in the pod + my $mess; + my %args; + if( @_ == 1 ) { + $mess = shift + } + else { + %args = @_; + $mess = $args{name} if exists( $args{name} ); + $mess = $args{title} if exists( $args{title} ); + $mess = $args{label} if exists( $args{label} ); + } + + # er, are we testing? + croak "Not testing. You must declare output with a test function first." + unless $testing; + + # okay, reconnect the test suite back to the saved handles + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + + # restore the test no, etc, back to the original point + $t->current_test($testing_num); + $testing = 0; + + # re-enable the original setting of the harness + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # check the output we've stashed + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) + ) + { + # print out the diagnostic information about why this + # test failed + + local $_; + + $t->diag( map { "$_\n" } $out->complaint ) + unless $args{skip_out} || $out->check; + + $t->diag( map { "$_\n" } $err->complaint ) + unless $args{skip_err} || $err->check; + } +} + +=item line_num + +A utility function that returns the line number that the function was +called on. You can pass it an offset which will be added to the +result. This is very useful for working out the correct text of +diagnostic functions that contain line numbers. + +Essentially this is the same as the C<__LINE__> macro, but the +C<line_num(+3)> idiom is arguably nicer. + +=cut + +sub line_num { + my( $package, $filename, $line ) = caller; + return $line + ( shift() || 0 ); # prevent warnings +} + +=back + +In addition to the six exported functions there there exists one +function that can only be accessed with a fully qualified function +call. + +=over 4 + +=item color + +When C<test_test> is called and the output that your tests generate +does not match that which you declared, C<test_test> will print out +debug information showing the two conflicting versions. As this +output itself is debug information it can be confusing which part of +the output is from C<test_test> and which was the original output from +your original tests. Also, it may be hard to spot things like +extraneous whitespace at the end of lines that may cause your test to +fail even though the output looks similar. + +To assist you C<test_test> can colour the background of the debug +information to disambiguate the different types of output. The debug +output will have it's background coloured green and red. The green +part represents the text which is the same between the executed and +actual output, the red shows which part differs. + +The C<color> function determines if colouring should occur or not. +Passing it a true or false value will enable or disable colouring +respectively, and the function called with no argument will return the +current setting. + +To enable colouring from the command line, you can use the +B<Text::Builder::Tester::Color> module like so: + + perl -Mlib=Text::Builder::Tester::Color test.t + +Or by including the B<Test::Builder::Tester::Color> module directly in +the PERL5LIB. + +=cut + +my $color; + +sub color { + $color = shift if @_; + $color; +} + +=back + +=head1 BUGS + +Calls C<<Test::Builder->no_ending>> turning off the ending tests. +This is needed as otherwise it will trip out because we've run more +tests than we strictly should have and it'll register any failures we +had that we were testing for as real failures. + +The color function doesn't work unless B<Term::ANSIColor> is +compatible with your terminal. + +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> + +=head1 AUTHOR + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +Some code taken from B<Test::More> and B<Test::Catch>, written by by +Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts +Copyright Micheal G Schwern 2001. Used and distributed with +permission. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 NOTES + +Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting +me use his testing system to try this module out on. + +=head1 SEE ALSO + +L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. + +=cut + +1; + +#################################################################### +# Helper class that is used to remember expected and received data + +package Test::Builder::Tester::Tie; + +## +# add line(s) to be expected + +sub expect { + my $self = shift; + + my @checks = @_; + foreach my $check (@checks) { + $check = $self->_translate_Failed_check($check); + push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; + } +} + +sub _translate_Failed_check { + my( $self, $check ) = @_; + + if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { + $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; + } + + return $check; +} + +## +# return true iff the expected data matches the got data + +sub check { + my $self = shift; + + # turn off warnings as these might be undef + local $^W = 0; + + my @checks = @{ $self->{wanted} }; + my $got = $self->{got}; + foreach my $check (@checks) { + $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); + return 0 unless $got =~ s/^$check//; + } + + return length $got == 0; +} + +## +# a complaint message about the inputs not matching (to be +# used for debugging messages) + +sub complaint { + my $self = shift; + my $type = $self->type; + my $got = $self->got; + my $wanted = join "\n", @{ $self->wanted }; + + # are we running in colour mode? + if(Test::Builder::Tester::color) { + # get color + eval { require Term::ANSIColor }; + unless($@) { + # colours + + my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); + my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); + my $reset = Term::ANSIColor::color("reset"); + + # work out where the two strings start to differ + my $char = 0; + $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); + + # get the start string and the two end strings + my $start = $green . substr( $wanted, 0, $char ); + my $gotend = $red . substr( $got, $char ) . $reset; + my $wantedend = $red . substr( $wanted, $char ) . $reset; + + # make the start turn green on and off + $start =~ s/\n/$reset\n$green/g; + + # make the ends turn red on and off + $gotend =~ s/\n/$reset\n$red/g; + $wantedend =~ s/\n/$reset\n$red/g; + + # rebuild the strings + $got = $start . $gotend; + $wanted = $start . $wantedend; + } + } + + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; +} + +## +# forget all expected and got data + +sub reset { + my $self = shift; + %$self = ( + type => $self->{type}, + got => '', + wanted => [], + ); +} + +sub got { + my $self = shift; + return $self->{got}; +} + +sub wanted { + my $self = shift; + return $self->{wanted}; +} + +sub type { + my $self = shift; + return $self->{type}; +} + +### +# tie interface +### + +sub PRINT { + my $self = shift; + $self->{got} .= join '', @_; +} + +sub TIEHANDLE { + my( $class, $type ) = @_; + + my $self = bless { type => $type }, $class; + + $self->reset; + + return $self; +} + +sub READ { } +sub READLINE { } +sub GETC { } +sub FILENO { } + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm new file mode 100755 index 00000000000..264fddbfd86 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Builder/Tester/Color.pm @@ -0,0 +1,51 @@ +package Test::Builder::Tester::Color; + +use strict; +our $VERSION = "1.18"; + +require Test::Builder::Tester; + + +=head1 NAME + +Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester + +=head1 SYNOPSIS + + When running a test script + + perl -MTest::Builder::Tester::Color test.t + +=head1 DESCRIPTION + +Importing this module causes the subroutine color in Test::Builder::Tester +to be called with a true value causing colour highlighting to be turned +on in debug output. + +The sole purpose of this module is to enable colour highlighting +from the command line. + +=cut + +sub import { + Test::Builder::Tester::color(1); +} + +=head1 AUTHOR + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 BUGS + +This module will have no effect unless Term::ANSIColor is installed. + +=head1 SEE ALSO + +L<Test::Builder::Tester>, L<Term::ANSIColor> + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm new file mode 100755 index 00000000000..5ba50944de1 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pm @@ -0,0 +1,517 @@ +use strict; +use warnings; + +package Test::Deep; +use Carp qw( confess ); + +use Test::Deep::Cache; +use Test::Deep::Stack; +use Test::Deep::RegexpVersion; + +require overload; +use Scalar::Util; + +my $Test; +unless (defined $Test::Deep::NoTest::NoTest) +{ +# for people who want eq_deeply but not Test::Builder + require Test::Builder; + $Test = Test::Builder->new; +} + +use Data::Dumper qw(Dumper); + +use vars qw( + $VERSION @EXPORT @EXPORT_OK @ISA + $Stack %Compared $CompareCache %WrapCache + $Snobby $Expects $DNE $DNE_ADDR $Shallow +); + +$VERSION = '0.106'; +$VERSION = eval $VERSION; + +require Exporter; +@ISA = qw( Exporter ); + +@EXPORT = qw( eq_deeply cmp_deeply cmp_set cmp_bag cmp_methods + useclass noclass set bag subbagof superbagof subsetof + supersetof superhashof subhashof +); + # plus all the ones generated from %constructors below + +@EXPORT_OK = qw( descend render_stack class_base cmp_details deep_diag ); + +$Snobby = 1; # should we compare classes? +$Expects = 0; # are we comparing got vs expect or expect vs expect + +$DNE = \""; +$DNE_ADDR = Scalar::Util::refaddr($DNE); + +# if no sub name is supplied then we use the package name in lower case +my %constructors = ( + Number => "num", + Methods => "", + ListMethods => "", + String => "str", + Boolean => "bool", + ScalarRef => "scalref", + ScalarRefOnly => "", + Array => "", + ArrayEach => "array_each", + ArrayElementsOnly => "", + Hash => "", + HashEach => "hash_each", + Regexp => "re", + RegexpMatches => "", + RegexpOnly => "", + RegexpRef => "", + Ignore => "", + Shallow => "", + Any => "", + All => "", + Isa => "Isa", + RegexpRefOnly => "", + RefType => "", + Blessed => "", + ArrayLength => "", + ArrayLengthOnly => "", + HashKeys => "", + HashKeysOnly => "", + Code => "", +); + +while (my ($pkg, $name) = each %constructors) +{ + $name = lc($pkg) unless $name; + my $full_pkg = "Test::Deep::$pkg"; + my $file = "$full_pkg.pm"; + $file =~ s#::#/#g; + my $sub = sub { + require $file; + return $full_pkg->new(@_); + }; + { + no strict 'refs'; + *{$name} = $sub; + } + push(@EXPORT, $name); +} +my %count; +foreach my $e (@EXPORT) +{ + $count{$e}++; +} + +# this is ugly, I should never have exported a sub called isa now I +# have to try figure out if the recipient wanted my isa or if a class +# imported us and UNIVERSAL::isa is being called on that class. +# Luckily our isa always expects 1 argument and U::isa always expects +# 2, so we can figure out (assuming the caller is no buggy). +sub isa +{ + if (@_ == 1) + { + goto &Isa; + } + else + { + goto &UNIVERSAL::isa; + } +} + +push(@EXPORT, "isa"); + +sub cmp_deeply +{ + my ($d1, $d2, $name) = @_; + + my ($ok, $stack) = cmp_details($d1, $d2); + + if (not $Test->ok($ok, $name)) + { + my $diag = deep_diag($stack); + $Test->diag($diag); + } + + return $ok; +} + +sub cmp_details +{ + my ($d1, $d2) = @_; + + local $Stack = Test::Deep::Stack->new; + local $CompareCache = Test::Deep::Cache->new; + local %WrapCache; + + my $ok = descend($d1, $d2); + + return ($ok, $Stack); +} + +sub eq_deeply +{ + my ($d1, $d2) = @_; + + my ($ok) = cmp_details($d1, $d2); + + return $ok +} + +sub eq_deeply_cache +{ + # this is like cross between eq_deeply and descend(). It doesn't start + # with a new $CompareCache but if the comparison fails it will leave + # $CompareCache as if nothing happened. However, if the comparison + # succeeds then $CompareCache retains all the new information + + # this allows Set and Bag to handle circular refs + + my ($d1, $d2, $name) = @_; + + local $Stack = Test::Deep::Stack->new; + $CompareCache->local; + + my $ok = descend($d1, $d2); + + $CompareCache->finish($ok); + + return $ok; +} + +sub deep_diag +{ + my $stack = shift; + # ick! incArrow and other things expect the stack has to be visible + # in a well known place . TODO clean this up + local $Stack = $stack; + + my $where = render_stack('$data', $stack); + + confess "No stack to diagnose" unless $stack; + my $last = $stack->getLast; + + my $diag; + my $message; + my $got; + my $expected; + + my $exp = $last->{exp}; + if (ref $exp) + { + if ($exp->can("diagnostics")) + { + $diag = $exp->diagnostics($where, $last); + $diag =~ s/\n+$/\n/; + } + else + { + if ($exp->can("diag_message")) + { + $message = $exp->diag_message($where); + } + } + } + + if (not defined $diag) + { + $got = $exp->renderGot($last->{got}) unless defined $got; + $expected = $exp->renderExp unless defined $expected; + $message = "Compared $where" unless defined $message; + + $diag = <<EOM +$message + got : $got +expect : $expected +EOM + } + + return $diag; +} + +sub render_val +{ + # add in Data::Dumper stuff + my $val = shift; + + my $rendered; + if (defined $val) + { + $rendered = ref($val) ? + (Scalar::Util::refaddr($val) eq $DNE_ADDR ? + "Does not exist" : + overload::StrVal($val) + ) : + qq('$val'); + } + else + { + $rendered = "undef"; + } + + return $rendered; +} + +sub descend +{ + my ($d1, $d2) = @_; + + if (! $Expects and ref($d1) and UNIVERSAL::isa($d1, "Test::Deep::Cmp")) + { + my $where = $Stack->render('$data'); + confess "Found a special comparison in $where\nYou can only the specials in the expects structure"; + } + + if (ref $d1 and ref $d2) + { + # this check is only done when we're comparing 2 expecteds against each + # other + + if ($Expects and UNIVERSAL::isa($d1, "Test::Deep::Cmp")) + { + # check they are the same class + return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1); + if ($d1->can("compare")) + { + return $d1->compare($d2); + } + } + + my $s1 = Scalar::Util::refaddr($d1); + my $s2 = Scalar::Util::refaddr($d2); + + if ($s1 eq $s2) + { + return 1; + } + if ($CompareCache->cmp($d1, $d2)) + { + # we've tried comparing these already so either they turned out to + # be the same or we must be in a loop and we have to assume they're + # the same + + return 1; + } + else + { + $CompareCache->add($d1, $d2) + } + } + + $d2 = wrap($d2); + + $Stack->push({exp => $d2, got => $d1}); + + if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR)) + { + # whatever it was suposed to be, it didn't exist and so it's an + # automatic fail + return 0; + } + + if ($d2->descend($d1)) + { +# print "d1 = $d1, d2 = $d2\nok\n"; + $Stack->pop; + + return 1; + } + else + { +# print "d1 = $d1, d2 = $d2\nnot ok\n"; + return 0; + } +} + +sub wrap +{ + my $data = shift; + + return $data if ref($data) and UNIVERSAL::isa($data, "Test::Deep::Cmp"); + + my ($class, $base) = class_base($data); + + my $cmp; + + if($base eq '') + { + $cmp = shallow($data); + } + else + { + my $addr = Scalar::Util::refaddr($data); + + return $WrapCache{$addr} if $WrapCache{$addr}; + + if($base eq 'ARRAY') + { + $cmp = array($data); + } + elsif($base eq 'HASH') + { + $cmp = hash($data); + } + elsif($base eq 'SCALAR' or $base eq 'REF') + { + $cmp = scalref($data); + } + elsif(($base eq 'Regexp') or ($base eq 'REGEXP')) + { + $cmp = regexpref($data); + } + else + { + $cmp = shallow($data); + } + + $WrapCache{$addr} = $cmp; + } + return $cmp; +} + +sub class_base +{ + my $val = shift; + + if (ref $val) + { + my $blessed = Scalar::Util::blessed($val); + $blessed = defined($blessed) ? $blessed : ""; + my $reftype = Scalar::Util::reftype($val); + + + if ($Test::Deep::RegexpVersion::OldStyle) { + if ($blessed eq "Regexp" and $reftype eq "SCALAR") + { + $reftype = "Regexp" + } + } + return ($blessed, $reftype); + } + else + { + return ("", ""); + } +} + +sub render_stack +{ + my ($var, $stack) = @_; + + return $stack->render($var); +} + +sub cmp_methods +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + return cmp_deeply(shift, methods(@{shift()}), shift); +} + +sub requireclass +{ + require Test::Deep::Class; + + my $val = shift; + + return Test::Deep::Class->new(1, $val); +} + +# docs and export say this is call useclass, doh! + +*useclass = \&requireclass; + +sub noclass +{ + require Test::Deep::Class; + + my $val = shift; + + return Test::Deep::Class->new(0, $val); +} + +sub set +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "", @_); +} + +sub supersetof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "sup", @_); +} + +sub subsetof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "sub", @_); +} + +sub cmp_set +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + return cmp_deeply(shift, set(@{shift()}), shift); +} + +sub bag +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "", @_); +} + +sub superbagof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "sup", @_); +} + +sub subbagof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "sub", @_); +} + +sub cmp_bag +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ref = ref($_[1]) || ""; + confess "Argument 2 to cmp_bag is not an ARRAY ref (".render_val($_[1]).")" + unless $ref eq "ARRAY"; + return cmp_deeply(shift, bag(@{shift()}), shift); +} + +sub superhashof +{ + require Test::Deep::Hash; + + my $val = shift; + + return Test::Deep::SuperHash->new($val); +} + +sub subhashof +{ + require Test::Deep::Hash; + + my $val = shift; + + return Test::Deep::SubHash->new($val); +} + +sub builder +{ + if (@_) + { + $Test = shift; + } + return $Test; +} + +1; + diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod new file mode 100755 index 00000000000..ffaab48b400 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep.pod @@ -0,0 +1,932 @@ +=head1 NAME + +Test::Deep - Extremely flexible deep comparison + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + use Test::Deep; + + cmp_deeply( + $actual_horrible_nested_data_structure, + $expected_horrible_nested_data_structure, + "got the right horrible nested data structure" + ); + + cmp_deeply( + $object, + methods(name => "John", phone => "55378008"), + "object methods ok" + ); + + cmp_deeply( + \@array, + [$hash1, $hash2, ignore( + "first 2 elements are as expected, ignoring 3" + ); + + cmp_deeply( + $object, + noclass({value => 5}), + "object looks ok, not checking it's class" + ); + + cmp_deeply( + \@result, + bag('a', 'b', {key => [1, 2]}), + "array has the 3 things we wanted in some order" + ); + +=head1 DESCRIPTION + +If you don't know anything about automated testing in Perl then you should +probably read about Test::Simple and Test::More before preceding. +Test::Deep uses the Test::Builder framework. + +Test::Deep gives you very flexible ways to check that the result you got is +the result you were expecting. At it's simplest it compares two structures +by going through each level, ensuring that the values match, that arrays and +hashes have the same elements and that references are blessed into the +correct class. It also handles circular data structures without getting +caught in an infinite loop. + +Where it becomes more interesting is in allowing you to do something besides +simple exact comparisons. With strings, the C<eq> operator checks that 2 +strings are exactly equal but sometimes that's not what you want. When you +don't know exactly what the string should be but you do know some things +about how it should look, C<eq> is no good and you must use pattern matching +instead. Test::Deep provides pattern matching for complex data structures + +=head1 EXAMPLES + +How Test::Deep works is much easier to understand by seeing some examples. + +=head2 Without Test::Deep + +Say you want to test a function which returns a string. You know that your +string should be a 7 digit number beginning with 0, C<eq> is no good in this +situation, you need a regular expression. So you could use Test::More's +C<like()> function: + + like($string, '/^0d{6}$/', "number looks good"); + +Similarly, to check that a string looks like a name, you could do: + + like($string, '/^(Mr|Mrs|Miss) \w+ \w+$/', + "got title, first and last name"); + +Now imagine your function produces a hash with some personal details in it. +You want to make sure that there are 2 keys, Name and Phone and that the +name looks like a name and the phone number looks like a phone number. You +could do: + + $hash = make_person(); + like($hash->{Name}, '/^(Mr|Mrs|Miss) \w+ \w+$/', "name ok"); + like($hash->{Phone}, '/^0d{6}$/', "phone ok"); + is(scalar keys %$hash, 2, "correct number of keys"); + +But that's not quite right, what if make_person has a serious problem and +didn't even return a hash? We really need to write + + if (ref($hash) eq "HASH") + { + like($hash->{Name}, '/^(Mr|Mrs|Miss) \w+ \w+$/', "name ok"); + like($hash->{Phone}, '/^0d{6}$/', "phone ok"); + is(scalar keys %$hash, 2, "correct number of keys"); + } + else + { + fail("person not a hash"); + fail("person not a hash"); + fail("person not a hash"); # need 3 to keep the plan correct + } + +Already this is getting messy, now imagine another entry in the hash, an +array of children's names. This would require + + + if (ref($hash) eq "HASH") + { + like($hash->{Name}, $name_pat, "name ok"); + like($hash->{Phone}, '/^0d{6}$/', "phone ok"); + my $cn = $hash->{ChildNames}; + if (ref($cn) eq "ARRAY") + { + foreach my $child (@$cn) + { + like($child, $name_pat); + } + } + else + { + fail("child names not an array") + } + } + else + { + fail("person not a hash"); + } + +This is a horrible mess and because we don't know in advance how many +children's names there will be, we can't make a plan for our test anymore +(actually, we could but it would make things even more complicated). + +Test::Deep to the rescue. + +=head2 With Test::Deep + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + cmp_deeply( + $person, + { + Name => $name_re, + Phone => re('^0d{6}$'), + ChildNames => array_each($name_re) + }, + "person ok" + ); + +This will do everything that the messy code above does and it will give a +sensible message telling you exactly what went wrong if it finds a part of +$person that doesn't match the pattern. C<re()> and C<array_each()> are +special function imported from Test::Deep. They create a marker that tells +Test::Deep that something different is happening here. Instead of just doing +a simple comparison and checking are two things exactly equal, it should do +something else. + +If a person was asked to check that 2 structures are equal, they could print +them both out and compare them line by line. The markers above are similar +to writing a note in red pen on one of the printouts telling the person that +for this piece of the structure, they should stop doing simple line by line +comparison and do something else. + +C<re($regex)> means that Test::Deep should check that the current piece of +data matches the regex in C<$regex>. C<array_each($struct)> means that +Test::Deep should expect the current piece of data to be an array and it +should check that every element of that array matches C<$struct>. +In this case, every element of C<$person->{ChildNames}> should look like a +name. If say the 3rd one didn't you would get an error message something +like + + Using Regexp on $data->{ChildNames}[3] + got : 'Queen John Paul Sartre' + expect : /^(Mr|Mrs|Miss) \w+ \w+$/ + +There are lots of other special comparisons available, see +L<SPECIAL COMPARISONS PROVIDED> below for the full list. + +=head2 Reusing structures + +Test::Deep is good for reusing test structures so you can do this + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + ChildNames => array_each($name_re) + }; + + cmp_deeply($person1, $person_cmp, "person ok"); + cmp_deeply($person2, $person_cmp, "person ok"); + cmp_deeply($person3, $person_cmp, "person ok"); + +You can even put $person_cmp in a module and let other people use it when +they are writing test scripts for modules that use your modules. + +To make things a little more difficult, lets change the person data +structure so that instead of a list of ChildNames, it contains a list of +hashes, one for each child. So in fact our person structure will contain +other person structures which may contain other person structures and so on. +This is easy to handle with Test::Deep because Test::Deep structures can +include themselves. Simply do + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + # note no mention of Children here + }; + + $person_cmp->{Children} = each_array($person_cmp); + + cmp_deeply($person, $person_cmp, "person ok"); + +This will now check that $person->{Children} is an array and that every +element of that array also matches C<$person_cmp>, this includes checking +that it's children also match the same pattern and so on. + +=head2 Circular data structures + +A circular data structure is one which loops back on itself, you can make +one easily by doing + + my @b; + my @a = (1, 2, 3, \@b); + push(@b, \@a); + +now @a contains a reference to be @b and @b contains a reference to @a. This +causes problems if you have a program that wants to look inside @a and keep +looking deeper and deeper at every level, it could get caught in an infinite +loop looking into @a then @b then @a then @b and so on. + +Test::Deep avoids this problem so we can extend our example further by +saying that a person should also list their parents. + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + # note no mention of Children here + }; + + $person_cmp->{Children} = each_array($person_cmp); + $person_cmp->{Parents} = each_array($person_cmp); + + cmp_deeply($person, $person_cmp, "person ok"); + +So this will check that for each child C<$child> in C<$person->{Children}> +that the C<$child->{Parents} matches C<$person_cmp> however it is smart +enough not to get caught in an infinite loop where it keeps bouncing between +the same Parent and Child. + +=head1 TERMINOLOGY + +C<cmp_deeply($got, $expected, $name)> takes 3 arguments. C<$got> is the +structure that you are checking, you must not include any special +comparisons in this structure or you will get a fatal error. C<$expected> +describes what Test::Deep will be looking for in $got. You can put special +comparisons in $expected if you want to. + +As Test::Deep descends through the 2 structures, it compares them one piece +at a time, so at any point in the process, Test::Deep is thinking about 2 +things - the current value from C<$got> and the current value from +C<$expected>. In the documentation, I call them C<$got_v> and C<exp_v> +respectively. + +=head1 COMPARISON FUNCTIONS + +=head3 $ok = cmp_deeply($got, $expected, $name) + +$got is the result to be checked. $expected is the structure against which +$got will be check. $name is the test name. + +This is the main comparison function, the others are just wrappers around +this. Without any special comparisons, it will descend into $expected, +following every reference and comparing C<$expected_v> to C<$got_v> (using +C<eq>) at the same position. If at any stage C<$expected_v> is a special +comparison then Test::Deep may do something else besides a simple string +comparison, exactly what it does depends on which special comparison it is. + +=head3 $ok = cmp_bag(\@got, \@bag, $name) + +Is shorthand for cmp_deeply(\@got, bag(@bag), $name) + +N.B. Both arguments must be array refs. If they aren't an error will +be raised via die. + +=head3 $ok = cmp_set(\@got, \@set, $name) + +Is shorthand for cmp_deeply(\@got, set(@set), $name) + +=head3 $ok = cmp_methods(\@got, \@methods, $name) + +Is shorthand for cmp_deeply(\@got, methods(@methods), $name) + +=head3 $ok = eq_deeply($got, $expected) + +This is the same as cmp_deeply() except it just returns true or +false. It does not create diagnostics or talk to L<Test::Builder>, but +if you want to use it in a non-testing environment then you should +import it through L<Test::Deep::NoTest>. For example + + use Test::Deep::NoTest; + print "a equals b" unless eq_deeply($a, $b); + +otherwise the L<Test::Builder> framework will be loaded and testing messages +will be output when your program ends. + +=head3 ($ok, $stack) = cmp_details($got, $expected) + +This behaves much like eq_deeply, but it additionally allows you to +produce diagnostics in case of failure by passing the value in C<$stack> +to C<deep_diag>. + +Do not make assumptions about the structure or content of C<$stack> and +do not use it if C<$ok> contains a true value. + +See L</USING TEST::DEEP WITH TEST::BUILDER> for example uses. + +=head1 SPECIAL COMPARISONS PROVIDED + +=head3 ignore() + +This makes Test::Deep skip tests on $got_v. No matter what value C<$got_v> +has, Test::Deep will think it's correct. This is useful if some part of the +structure you are testing is very complicated and already tested elsewhere, +or is unpredictable. + + cmp_deeply($got, { name => 'John', random => ignore(), address => ['5 A + street', 'a town', 'a country'], + }) + +is the equivalent of checking + + $got->{name} eq 'John'; + exists $got->{random}; + cmp_deeply($got->{address}; + ['5 A street', 'a town', 'a country']); + +=head3 methods(%hash) + +%hash is a hash of method call => expected value pairs. + +This lets you call methods on an object and check the result of each call. +The methods will be called in the order supplied. If you want to pass +arguments to the method you should wrap the method name and arguments in an +array reference. + + cmp_deeply( + $obj, + methods(name => "John", ["favourite", "food"] => "taco") + ); + +is roughly the equivalent of checking that + + $obj->name eq "John" + $obj->favourite("food") eq "taco" + +The methods will be called in the order you supply them and will be called +in scalar context. If you need to test methods called in list context then +you should use listmethods(). + +B<NOTE> Just as in a normal test script, you need to be careful if the +methods you call have side effects like changing the object or other objects +in the structure. Although the order of the methods is fixed, the order of +some other tests is not so if $expected is + + { + manager => methods(@manager_methods), + coder => methods(@coder_methods) + } + +there is no way to know which if manager and coder will be tested first. If +the methods you are testing depend on and alter global variables or if +manager and coder are the same object then you may run into problems. + +=head3 listmethods(%hash) + +%hash is a hash of method call => expected value pairs. + +This is almost identical to methods() except the methods are called in list +context instead of scalar context. This means that the expected values +supplied must be an array reference. + + cmp_deeply( + $obj, + listmethods( + name => "John", + ["favourites", "food"] => ["Mapo tofu", "Gongbao chicken"] + ) + ); + +is the equivalent of checking that + + $obj->name eq "John" + cmp_deeply([$obj->favourites("food")], ["Mapo tofu", "Gongbao chicken"]); + +The methods will be called in the order you supply them. + +B<NOTE> The same caveats apply as for methods(). + +=head3 shallow($thing) + +$thing is a ref. + +This prevents Test::Deep from looking inside $thing. It allows you to +check that $got_v and $thing are references to the same variable. So + + my @a = @b = (1, 2, 3); + cmp_deeply(\@a, \@b); + +will pass because @a and @b have the same elements however + + cmp_deeply(\@a, shallow(\@b)) + +will fail because although \@a and \@b both contain C<1, 2, 3> they are +references to different arrays. + +=head3 noclass($thing) + +$thing is a structure to be compared against. + +This makes Test::Deep ignore the class of objects, so it just looks at the +data they contain. Class checking will be turned off until Test::Deep is +finished comparing C<$got_v> against C<$thing>. Once Test::Deep comes out of +C<$thing> it will go back to it's previous setting for checking class. + +This can be useful when you want to check that objects have been +constructed correctly but you don't want to write lots of +C<bless>es. If \@people is an array of Person objects then + + cmp_deeply(\@people, noclass([ + bless {name => 'John', phone => '555-5555'}, "Person", + bless {name => 'Anne', phone => '444-4444'}, "Person", + ])); + +can be replaced with + + cmp_deeply(\@people, noclass([ + {name => 'John', phone => '555-5555'}, + {name => 'Anne', phone => '444-4444'} + ])); + +However, this is testing so you should also check that the objects are +blessed correctly. You could use a map to bless all those hashes or you +could do a second test like + + cmp_deeply($people, array_each(isa("Person")); + +=head3 useclass($thing) + +This turns back on the class comparison while inside a noclass(). + + cmp_deeply( + $got, + noclass( + [ + useclass( $object ) + ] + ) + ) + +In this example the class of the array reference in C<$got> is ignored but +the class of C<$object> is checked, as is the class of everything inside +C<$object>. + +=head3 re($regexp, $capture_data, $flags) + +$regexp is either a regular expression reference produced with C<qr/.../> or +a string which will be used to construct a regular expression. + +$capture_data is optional and is used to check the strings captured by +an regex. This should can be an array ref or a Test::Deep comparator +that works on array refs. + +$flags is an optional string which controls whether the regex runs as a +global match. If $flags is "g" then the regex will run as m/$regexp/g. + +Without $capture_data, this simply compares $got_v with the regular expression +provided. So + + cmp_deeply($got, [ re("ferg") ]) + +is the equivalent of + + $got->[0] =~ /ferg/ + +With $capture_data + + cmp_deeply($got, [re($regex, $capture_data]) + +is the equivalent of + + my @data = $got->[0] =~ /$regex/; + cmp_deeply(\@data, $capture_data); + +So you can do something simple like + + cmp_deeply($got, re(qr/(\d\d)(\w\w)/, [25, "ab" ]) + +to check that (\d\d) was 25 and (\w\w) was "ab" but you can also use +Test::Deep objects to do more complex testing of the captured values + + cmp_deeply("cat=2,dog=67,sheep=3,goat=2,dog=5", + re(qr/(\D+)=\d+,?/, set(qw( cat sheep dog )), "g")) + +here, the regex will match the string and will capture the animal names and +check that they match the specified set, in this case it will fail, +complaining that "goat" is not in the set. + +=head3 superhashof(\%hash) + +This will check that the hash C<%$got> is a "super-hash" of C<%hash>. That +is that all the key and value pairs in C<%hash> appear in C<%$got> but +C<%$got> can have extra ones also. + +For example + + cmp_deeply({a => 1, b => 2}, superhashof({a => 1})) + +will pass but + + cmp_deeply({a => 1, b => 2}, superhashof({a => 1, c => 3})) + +will fail. + +=head3 subhashof(\%hash) + +This will check that the hash C<%$got> is a "sub-hash" of C<%hash>. That is +that all the key and value pairs in C<%$got> also appear in C<%hash>. + +For example + + cmp_deeply({a => 1}, subhashof({a => 1, b => 2})) + +will pass but + + cmp_deeply({a => 1, c => 3}, subhashof({a => 1, b => 2})) + +will fail. + +=head3 bag(@elements) + +@elements is an array of elements. + +This does a bag comparison, that is, it compares two arrays but ignores the +order of the elements so + + cmp_deeply([1, 2, 2], bag(2, 2, 1)) + +will be a pass. + +The object returned by bag() has an add() method. + + my $bag = bag(1, 2, 3); + $bag->add(2, 3, 4); + +will result in a bag containing 1, 2, 2, 3, 3, 4. + +C<NOTE> If you use certain special comparisons within a bag or set +comparison there is a danger that a test will fail when it should have +passed. It can only happen if two or more special comparisons in the bag are +competing to match elements. Consider this comparison + + cmp_deeply(['furry', 'furball'], bag(re("^fur"), re("furb"))) + +There are two things that could happen, hopefully C<re("^fur")> is paired with +"furry" and C<re("^furb")> is paired with "furb" and everything is fine but it +could happen that C<re("^fur")> is paired with "furball" and then C<re("^furb")> +cannot find a match and so the test fails. Examples of other competing +comparisons are C<bag(1, 2, 2)> vs C<set(1, 2)> and +C<methods(m1 => "v1", m2 => "v2")> vs C<methods(m1 => "v1")> + +This problem is could be solved by using a slower and more complicated +algorithm for set and bag matching. Something for the future... + +=head3 set(@elements) + +@elements is an array of elements. + +This does a set comparison, that is, it compares two arrays but ignores the +order of the elements and it ignores duplicate elements, so + + cmp_deeply([1, 2, 2, 3], set(3, 2, 1, 1)) + +will be a pass. + +The object returned by set() has an add() method. + + my $set = set(1, 2, 3); + $set->add(4, 5, 6); + +will result in a set containing 1, 2, 3, 4, 5, 5. + +C<NOTE> See the NOTE on the bag() comparison for some dangers in using +special comparisons inside set() + +=head3 superbagof(@elements), subbagof(@elements), supersetof(@elements) and subsetof(@elements) + +@elements is an array of elements. + +These do exactly what you'd expect them to do, so for example + + cmp_deeply($data, subbagof(1, 1, 3, 4)); + +checks that @$data contains at most 2 "1"s, 1 "3" and 1 "4" and + + cmp_deeply($data, supsersetof(1, 4)); + +check that @$data contains at least 1 "1" and 1 "4". + +These are just special cases of the Set and Bag comparisons so they also +give you an add() method and they also have the same limitations when using +special comparisons inside them (see the NOTE in the bag() section). + +=head3 all(@expecteds) + +@expecteds is an array of expected structures. + +This allows you to compare data against multiple expected results and make +sure each of them matches. + + cmp_deeply($got, all(isa("Person"), methods(name => 'John'))) + +is equivalent to + + $got->isa("Person") + $got->name eq 'John' + +If either test fails then the whole thing is considered a fail. This is a +short-circuit test, the testing is stopped after the first failure, although +in the future it may complete all tests so that diagnostics can be output +for all failures. When reporting failure, the parts are counted from 1. + +Thanks to the magic of overloading, you can write + + all(isa("Person"), methods(name => 'John'), re("^wi")) + +as + + isa("Person") & methods(name => 'John') | re("^wi") + +Note B<single> | not double as || cannot be overloaded. This will only work +when there is a special comparison involved. If you write + + "john" | "anne" | "robert" + +Perl will turn this into + + "{onort" + +which is presumably not what you wanted. This is because Perl |s them +together as strings before Test::Deep gets a chance to do any overload +tricks. + +=head3 any(@expecteds) + +@expecteds is an array of expected structures. + +This can be used to compare data against multiple expected results and make +sure that at least one of them matches. This is a short-circuit test so if +a test passes then none of the tests after that will be attempted. + +You can also use overloading with | similarly to all(). + +=head3 isa($class), Isa($class) + +$class is a class name. + +This uses UNIVERSAL::isa() to check that $got_v is blessed into the class +$class. + +B<NOTE:> Isa() does exactly as documented here, isa() is slightly +different. If isa() is called with 1 argument it falls through to +Isa(). If isa() called with 2 arguments, it falls through to +UNIVERAL::isa. This is to prevent breakage when you import isa() into +a package that is used as a class. Without this, anyone calling +C<Class-E<gt>isa($other_class)> would get the wrong answer. This is a +hack to patch over the fact that isa is exported by default. + +=head3 array_each($thing) + +$thing is a structure to be compared against. + +<$got_v> must be an array reference. Each element of it will be compared to +$thing. This is useful when you have an array of similar things, for example +objects of a known type and you don't want to have to repeat the same test +for each one. + + my $common_tests = all( + isa("MyFile"), + methods( + handle => isa("IO::Handle") + filename => re("^/home/ted/tmp"), + ) + ); + + cmp_deeply($got, array_each($common_tests)); + +is similar to + + foreach my $got_v (@$got) { + cmp_deeply($got_v, $common_tests) + } + +Except it will not explode is $got is not an array reference. It will check +that each of the objects in @$got is a MyFile and that each one gives the +correct results for it's methods. + +You could go further, if for example there were 3 files and you knew the +size of each one you could do this + + cmp_deeply( + $got, + all( + array_each($common_tests), + [ + methods(size => 1000), + methods(size => 200), + methods(size => 20) + ] + ) + ) + cmp_deeply($got, array_each($structure)); + +=head3 str($string) + +$string is a string. + +This will stringify C<$got_v> and compare it to C<$string> using C<eq>, even +if $got_v is a ref. It is useful for checking the stringified value of an +overloaded reference. + +=head3 num($number, $tolerance) + +$number is a number. +$tolerance is an optional number. + +This will add 0 to C<$got_v> and check if it's numerically equal to +C<$number>, even if $got_v is a ref. It is useful for checking the numerical +value of an overloaded reference. If $tolerance is supplied then this will +check that $got_v and $exp_v are less than $tolerance apart. This is useful +when comparing floating point numbers as rounding errors can make it hard or +impossible for $got_v to be exactly equal to $exp_v. When $tolerance is +supplied, the test passes if C<abs($got_v - $exp_v) <= $tolerance>. + +B<Note> in Perl, C<"12blah" == 12> because Perl will be smart and convert +"12blah" into 12. You may not want this. There was a strict mode but that is +now gone. A "lookslike s number" test will replace it soon. Until then you +can usually just use the string() comparison to be more strict. This will +work fine for almost all situations, however it will not work when <$got_v> +is an overloaded value who's string and numerical values differ. + +=head3 bool($value) + +$value is anything you like but it's probably best to use 0 or 1 + +This will check that C<$got_v> and C<$value> have the same truth value, that +is they will give the same result when used in boolean context, like in an +if() statement. + +=head3 code(\&subref) + +\&subref is a reference to a subroutine which will be passed a single +argument, it then should return a true or false and possibly a string + +This will pass C<$got_v> to the subroutine which returns true or false to +indicate a pass or fail. Fails can be accompanied by a diagnostic string +which gives an explanation of why it's a fail. + + sub check_name + { + my $name = shift; + if ($boss->likes($name)) + { + return 1; + } + else + { + return (0, "the boss doesn't like your name"); + } + } + + cmp_deeply("Brian", \&check_name); + +=head1 DIAGNOSTIC FUNCTIONS + +=head3 my $reason = deep_diag($stack) + +C<$stack> is a value returned by cmp_details. Do not call this function +if cmp_details returned a true value for C<$ok>. + +deep_diag() returns a human readable string describing how the +comparison failed. + +=head1 ANOTHER EXAMPLE + +You've written a module to handle people and their film interests. Say you +have a function that returns an array of people from a query, each person is +a hash with 2 keys: Name and Age and the array is sorted by Name. You can do + + cmp_deeply( + $result, + [ + {Name => 'Anne', Age => 26}, + {Name => "Bill", Age => 47} + {Name => 'John', Age => 25}, + ] + ); + +Soon after, your query function changes and all the results now have an ID +field. Now your test is failing again because you left out ID from each of +the hashes. The problem is that the IDs are generated by the database and +you have no way of knowing what each person's ID is. With Test::Deep you can +change your query to + + cmp_deeply( + $result, + [ + {Name => 'John', Age => 25, ID => ignore()}, + {Name => 'Anne', Age => 26, ID => ignore()}, + {Name => "Bill", Age => 47, ID => ignore()} + ] + ); + +But your test still fails. Now, because you're using a database, you no +longer know what order the people will appear in. You could add a sort into +the database query but that could slow down your application. Instead you +can get Test::Deep to ignore the order of the array by doing a bag +comparison instead. + + cmp_deeply( + $result, + bag( + {Name => 'John', Age => 25, ID => ignore()}, + {Name => 'Anne', Age => 26, ID => ignore()}, + {Name => "Bill", Age => 47, ID => ignore()} + ) + ); + +Finally person gets even more complicated and includes a new field called +Movies, this is a list of movies that the person has seen recently, again +these movies could also come back in any order so we need a bag inside our +other bag comparison, giving us something like + + cmp_deeply( + $result, + bag( + {Name => 'John', Age => 25, ID => ignore(), Movies => bag(...)}, + {Name => 'Anne', Age => 26, ID => ignore(), Movies => bag(...)}, + {Name => "Bill", Age => 47, ID => ignore(), Movies => bag(...)} + ) + ); + +=head1 USING TEST::DEEP WITH TEST::BUILDER + +Combining C<cmp_details> and C<test_diag> makes it possible to use +Test::Deep in your own test classes. + +In a L<Test::Builder> subclass, create a test method in the following +form: + + sub behaves_ok { + my $self = shift; + my $expected = shift; + my $test_name = shift; + + my $got = do_the_important_work_here(); + + my ($ok, $stack) = cmp_details($got, $expected); + unless ($Test->ok($ok, $test_name)) { + my $diag = deep_diag($stack); + $Test->diag($diag); + } + } + +As the subclass defines a test class, not tests themselves, make sure it +uses L<Test::Deep::NoTest>, not C<Test::Deep> itself. + +=head1 LIMITATIONS + +Currently any CODE, GLOB or IO refs will be compared using shallow(), which +means only their memory addresses are compared. + +=head1 BUGS + +There is a bug in set and bag compare to do with competing SCs. It only +occurs when you put certain special comparisons inside bag or set +comparisons you don't need to worry about it. The full details are in the +bag() docs. It will be fixed in an upcoming version. + +=head1 WHAT ARE SPECIAL COMPARISONS? + +A special comparison (SC) is simply an object that inherits from +Test::Deep::Cmp. Whenever C<$expected_v> is an SC then instead of checking +C<$got_v eq $expected_v>, we pass control over to the SC and let it do it's +thing. + +Test::Deep exports lots of SC constructors, to make it easy for you to use +them in your test scripts. For example is C<re("hello")> is just a handy way +of creating a Test::Deep::Regexp object that will match any string containing +"hello". So + + cmp_deeply([ 'a', 'b', 'hello world'], ['a', 'b', re("^hello")]); + +will check C<'a' eq 'a'>, C<'b' eq 'b'> but when it comes to comparing +C<'hello world'> and C<re("^hello")> it will see that +$expected_v is an SC and so will pass control to the Test::Deep::Regexp class +by do something like C<$expected_v->descend($got_v)>. The C<descend()> +method should just return true or false. + +This gives you enough to write your own SCs but I haven't documented how +diagnostics works because it's about to get an overhaul. + +=head1 SEE ALSO + +L<Test::More> + +=head1 AUTHOR + +Fergal Daly E<lt>fergal@esatclear.ieE<gt>, with thanks to Michael G Schwern +for Test::More's is_deeply function which inspired this. + +=head1 COPYRIGHT + +Copyright 2003, 2004 by Fergal Daly E<lt>fergal@esatclear.ieE<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 diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm new file mode 100755 index 00000000000..d171d3fa7a1 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/All.pm @@ -0,0 +1,64 @@ +use strict; +use warnings; + +package Test::Deep::All; + +use Test::Deep::Cmp; + +use overload + '&' => \&add, + fallback => 1, +; + +sub init +{ + my $self = shift; + + my @list = map {Test::Deep::wrap($_)} @_; + + $self->{val} = \@list; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $data = $self->data; + + my $index = 1; + + foreach my $cmp (@{$self->{val}}) + { + $data->{index} = $index; + $index++; + + next if Test::Deep::descend($got, $cmp); + return 0 + } + + return 1; +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + my $data = shift; + + my $max = @{$self->{val}}; + + return "(Part $data->{index} of $max in $var)"; +} + +sub add +{ + my $self = shift; + my $expect = shift; + + push(@{$self->{val}}, Test::Deep::wrap($expect)); + + return $self; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm new file mode 100755 index 00000000000..2485d9b87f9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Any.pm @@ -0,0 +1,65 @@ +use strict; +use warnings; + +package Test::Deep::Any; + +use Test::Deep::Cmp; + +use overload + '&' => \&add, + fallback => 1, +; + +sub init +{ + my $self = shift; + + my @list = map {Test::Deep::wrap($_)} @_; + + $self->{val} = \@list; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + foreach my $cmp (@{$self->{val}}) + { + return 1 if Test::Deep::eq_deeply_cache($got, $cmp); + } + + return 0; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $expect = $self->{val}; + + my $got = $self->renderGot($last->{got}); + my $things = join(", ", map {$_->renderExp} @$expect); + + my $diag = <<EOM; +Comparing $where with Any +got : $got +expected : Any of ( $things ) +EOM + + $diag =~ s/\n+$/\n/; + return $diag; +} + +sub add +{ + my $self = shift; + my $expect = shift; + + push(@{$self->{val}}, Test::Deep::wrap($expect)); + + return $self; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm new file mode 100755 index 00000000000..27c3cd3fe41 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Array.pm @@ -0,0 +1,36 @@ +use strict; +use warnings; + +package Test::Deep::Array; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless Test::Deep::descend($got, Test::Deep::arraylength(scalar @$exp)); + + return 0 unless $self->test_class($got); + + return Test::Deep::descend($got, Test::Deep::arrayelementsonly($exp)); +} + +sub reset_arrow +{ + return 0; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm new file mode 100755 index 00000000000..f6d9417d5f5 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayEach.pm @@ -0,0 +1,27 @@ +use strict; +use warnings; + +package Test::Deep::ArrayEach; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = [ ($self->{val}) x @$got ]; + + return Test::Deep::descend($got, $exp); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm new file mode 100755 index 00000000000..7704e80f6d6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayElementsOnly.pm @@ -0,0 +1,54 @@ +use strict; +use warnings; + +package Test::Deep::ArrayElementsOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + for my $i (0..$#{$exp}) + { + $data->{index} = $i; + + my $got_elem = $got->[$i]; + my $exp_elem = $exp->[$i]; + + return 0 unless Test::Deep::descend($got_elem, $exp_elem) + } + + return 1; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + $var .= "->" unless $Test::Deep::Stack->incArrow; + $var .= "[$data->{index}]"; + + return $var; +} + +sub reset_arrow +{ + return 0; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm new file mode 100755 index 00000000000..a4c2c6ac8a1 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLength.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::ArrayLength; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless $self->test_reftype($got, "ARRAY"); + + return Test::Deep::descend($got, Test::Deep::arraylengthonly($exp)); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm new file mode 100755 index 00000000000..ac11967ff21 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ArrayLengthOnly.pm @@ -0,0 +1,60 @@ +use strict; +use warnings; + +package Test::Deep::ArrayLengthOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $len = $self->{val}; + + return @$got == $len; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "array length of $var"; +} + +sub renderVal +{ + my $self = shift; + + my $val = shift; + + return "array with $val element(s)" +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + return $self->renderVal(@$got + 0); +} + +sub renderExp +{ + my $self = shift; + + return $self->renderVal($self->{val}); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm new file mode 100755 index 00000000000..62fdc48c358 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Blessed.pm @@ -0,0 +1,47 @@ +use strict; +use warnings; + +package Test::Deep::Blessed; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + my $blessed = blessed($got); + + return Test::Deep::descend($blessed, Test::Deep::shallow($exp)); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return "blessed($var)" +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + $self->SUPER::renderGot(blessed($got)); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm new file mode 100755 index 00000000000..e0204031718 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Boolean.pm @@ -0,0 +1,46 @@ +use strict; +use warnings; + +package Test::Deep::Boolean; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{val} = shift() ? 1 : 0; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return !( $got xor $self->{val} ); +} + +sub diag_message +{ + my $self = shift; + my $where = shift; + return "Comparing $where as a boolean"; +} + +sub renderExp +{ + my $self = shift; + + $self->renderGot($self->{val}); +} + +sub renderGot +{ + my $self = shift; + + my $val = shift; + + return ($val ? "true" : "false")." (".Test::Deep::render_val($val).")"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm new file mode 100755 index 00000000000..e9ffd952740 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache.pm @@ -0,0 +1,78 @@ +use strict; +use warnings; + +package Test::Deep::Cache; + +use Test::Deep::Cache::Simple; + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->{expects} = [Test::Deep::Cache::Simple->new]; + $self->{normal} = [Test::Deep::Cache::Simple->new]; + + $self->local; + + return $self; +} + +sub add +{ + my $self = shift; + + my $type = $self->type; + + $self->{$type}->[-1]->add(@_); +} + +sub cmp +{ + # go through all the caches to see if we know this one + + my $self = shift; + + my $type = $self->type; + + foreach my $cache (@{$self->{$type}}) + { + return 1 if $cache->cmp(@_); + } + + return 0 +} + +sub local +{ + my $self = shift; + + foreach my $type (qw( expects normal )) + { + push(@{$self->{$type}}, Test::Deep::Cache::Simple->new); + } +} + +sub finish +{ + my $self = shift; + + my $keep = shift; + + foreach my $type (qw( expects normal )) + { + my $caches = $self->{$type}; + + my $last = pop @$caches; + + $caches->[-1]->absorb($last) if $keep; + } +} + +sub type +{ + return $Test::Deep::Expects ? "expects" : "normal"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm new file mode 100755 index 00000000000..e8e76a41438 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cache/Simple.pm @@ -0,0 +1,81 @@ +use strict; +use warnings; + +package Test::Deep::Cache::Simple; +use Carp qw( confess ); + +use Scalar::Util qw( refaddr ); + +BEGIN +{ + if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL) + { + # we're running on a version of perl that has no weak refs, so we + # just install a no-op sub for weaken instead of importing it + *weaken = sub {}; + } + else + { + Scalar::Util->import('weaken'); + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + return $self; +} + +sub add +{ + my $self = shift; + + my ($d1, $d2) = @_; + { + local $SIG{__DIE__}; + + # cannot weaken read only refs, no harm if we can't as they never + # disappear + eval{weaken($d1)}; + eval{weaken($d2)}; + } + + $self->{fn_get_key(@_)} = [$d1, $d2]; +} + +sub cmp +{ + my $self = shift; + + my $key = fn_get_key(@_); + my $pair = $self->{$key}; + + # are both weakened refs still valid, if not delete this entry + if (ref($pair->[0]) and ref($pair->[1])) + { + return 1; + } + else + { + delete $self->{$key}; + return 0; + } +} + +sub absorb +{ + my $self = shift; + + my $other = shift; + + @{$self}{keys %$other} = values %$other; +} + +sub fn_get_key +{ + return join(",", sort (map {refaddr($_)} @_)); +} +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm new file mode 100755 index 00000000000..2e58484f608 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Class.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::Class; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $snobby = shift; + my $val = shift; + + $self->{snobby} = $snobby; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + local $Test::Deep::Snobby = $self->{snobby}; + + Test::Deep::wrap($self->{val})->descend($got); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm new file mode 100755 index 00000000000..adc8ffb8b81 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Cmp.pm @@ -0,0 +1,130 @@ +use strict; +use warnings; + +package Test::Deep::Cmp; + +use overload + '&' => \&make_all, + '|' => \&make_any, + '""' => \&string, + fallback => 1, +; + +sub import +{ + my $pkg = shift; + + my $callpkg = caller(); + if ($callpkg =~ /^Test::Deep::/) + { + no strict 'refs'; + + push @{$callpkg."::ISA"}, $pkg; + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->init(@_); + return $self; +} + +sub init +{ +} + +sub make_all +{ + my ($e1, $e2) = @_; + + if (UNIVERSAL::isa($e1, "Test::Deep::All")) + { + $e1->add($e2); + return $e1; + } + elsif(UNIVERSAL::isa($e2, "Test::Deep::All")) + { + $e2->add($e1); + return $e2; + } + else + { + return Test::Deep::all($e1, $e2); + } +} + +sub make_any +{ + my ($e1, $e2) = @_; + + if (UNIVERSAL::isa($e1, "Test::Deep::Any")) + { + $e1->add($e2); + return $e1; + } + elsif(UNIVERSAL::isa($e2, "Test::Deep::Any")) + { + $e2->add($e1); + return $e2; + } + else + { + return Test::Deep::any($e1, $e2); + } +} + +sub cmp +{ + my ($a1, $a2, $rev) = @_; + + ($a1, $a2) = ($a2, $a1) if $rev; + + return (overload::StrVal($a1) cmp overload::StrVal($a2)); +} + +sub string +{ + my $self = shift; + + return overload::StrVal($self); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return $var; +} + +sub renderExp +{ + my $self = shift; + + return $self->renderGot($self->{val}); +} + +sub renderGot +{ + my $self = shift; + + return Test::Deep::render_val(@_); +} + +sub reset_arrow +{ + return 1; +} + +sub data +{ + my $self = shift; + + return $Test::Deep::Stack->getLast; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm new file mode 100755 index 00000000000..8768a590f6d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Code.pm @@ -0,0 +1,58 @@ +use strict; +use warnings; + +package Test::Deep::Code; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $code = shift || die "No coderef supplied"; + + $self->{code} = $code; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my ($ok, $diag) = &{$self->{code}}($got); + + $self->data->{diag} = $diag; + + return $ok; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $error = $last->{diag}; + my $data = Test::Deep::render_val($last->{got}); + my $diag = <<EOM; +Ran coderef at $where on + +$data +EOM + if (defined($error)) + { + $diag .= <<EOM; +and it said +$error +EOM + } + else + { + $diag .= <<EOM; +it failed but it didn't say why. +EOM + } + + return $diag; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm new file mode 100755 index 00000000000..75975248e24 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Hash.pm @@ -0,0 +1,104 @@ +use strict; +use warnings; + +package Test::Deep::Hash; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + return 0 unless Test::Deep::descend($got, $self->hash_keys($exp)); + + return 0 unless $self->test_class($got); + + return Test::Deep::descend($got, $self->hash_elements($exp)); +} + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::HashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::HashKeys->new(keys %$exp); +} + +sub reset_arrow +{ + return 0; +} + +package Test::Deep::SuperHash; + +use base 'Test::Deep::Hash'; + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::SuperHashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SuperHashKeys->new(keys %$exp); +} + +package Test::Deep::SubHash; + +use base 'Test::Deep::Hash'; + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::SubHashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SubHashKeys->new(keys %$exp); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm new file mode 100755 index 00000000000..b1937c6a780 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashEach.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::HashEach; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my %exp; + + @exp{keys %$got} = ($self->{val}) x (keys %$got); + + return Test::Deep::descend($got, \%exp); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm new file mode 100755 index 00000000000..c398ecacf97 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashElements.pm @@ -0,0 +1,94 @@ +use strict; +use warnings; + +package Test::Deep::HashElements; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + my $master = $self->getMaster($got, $exp); + + foreach my $key (keys %$master) + { + $data->{index} = $key; + + my $got_elem = exists $got->{$key} ? $got->{$key} : $Test::Deep::DNE; + my $exp_elem = exists $exp->{$key} ? $exp->{$key} : $Test::Deep::DNE; + + next if Test::Deep::descend($got_elem, $exp_elem); + + return 0; + } + + return 1; +} + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return keys %$got > keys %$exp ? $got : $exp; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + $var .= "->" unless $Test::Deep::Stack->incArrow; + $var .= '{"'.quotemeta($data->{index}).'"}'; + + return $var; +} + +sub reset_arrow +{ + return 0; +} + +package Test::Deep::SuperHashElements; + +use base 'Test::Deep::HashElements'; + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return $exp; +} + +package Test::Deep::SubHashElements; + +use base 'Test::Deep::HashElements'; + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return $got; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm new file mode 100755 index 00000000000..d0f6fc4afc6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeys.pm @@ -0,0 +1,68 @@ +use strict; +use warnings; + +package Test::Deep::HashKeys; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my %keys; + @keys{@_} = (); + $self->{val} = \%keys; + $self->{keys} = [sort @_]; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless $self->test_reftype($got, "HASH"); + + return Test::Deep::descend($got, $self->hashkeysonly($exp)); +} + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::HashKeysOnly->new(keys %$exp) +} + +package Test::Deep::SuperHashKeys; + +use base 'Test::Deep::HashKeys'; + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SuperHashKeysOnly->new(keys %$exp) +} + +package Test::Deep::SubHashKeys; + +use base 'Test::Deep::HashKeys'; + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SubHashKeysOnly->new(keys %$exp) +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm new file mode 100755 index 00000000000..26b7de36fdb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm @@ -0,0 +1,126 @@ +use strict; +use warnings; + +package Test::Deep::HashKeysOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my %keys; + @keys{@_} = (); + $self->{val} = \%keys; + $self->{keys} = [sort @_]; +} + +sub descend +{ + my $self = shift; + my $hash = shift; + + my $data = $self->data; + my $exp = $self->{val}; + my %got; + @got{keys %$hash} = (); + + my @missing; + my @extra; + + while (my ($key, $value) = each %$exp) + { + if (exists $got{$key}) + { + delete $got{$key}; + } + else + { + push(@missing, $key); + } + } + + my @diags; + if (@missing and (not $self->ignoreMissing)) + { + push(@diags, "Missing: ".nice_list(\@missing)); + } + + if (%got and (not $self->ignoreExtra)) + { + push(@diags, "Extra: ".nice_list([keys %got])); + } + + if (@diags) + { + $data->{diag} = join("\n", @diags); + return 0; + } + + return 1; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $type = $self->{IgnoreDupes} ? "Set" : "Bag"; + + my $error = $last->{diag}; + my $diag = <<EOM; +Comparing hash keys of $where +$error +EOM + + return $diag; +} + +sub nice_list +{ + my $list = shift; + + return join(", ", + (map {"'$_'"} sort @$list), + ); +} + +sub ignoreMissing +{ + return 0; +} + +sub ignoreExtra +{ + return 0; +} + +package Test::Deep::SuperHashKeysOnly; + +use base 'Test::Deep::HashKeysOnly'; + +sub ignoreMissing +{ + return 0; +} + +sub ignoreExtra +{ + return 1; +} + +package Test::Deep::SubHashKeysOnly; + +use base 'Test::Deep::HashKeysOnly'; + +sub ignoreMissing +{ + return 1; +} + +sub ignoreExtra +{ + return 0; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm new file mode 100755 index 00000000000..2aadcf59772 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ignore.pm @@ -0,0 +1,20 @@ +use strict; +use warnings; + +package Test::Deep::Ignore; + +use Test::Deep::Cmp; + +my $Singleton = __PACKAGE__->SUPER::new; + +sub new +{ + return $Singleton; +} + +sub descend +{ + return 1; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm new file mode 100755 index 00000000000..5face21b51a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Isa.pm @@ -0,0 +1,33 @@ +use strict; +use warnings; + +package Test::Deep::Isa; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return UNIVERSAL::isa($got, $self->{val}); +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Checking class of $where with isa()"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm new file mode 100755 index 00000000000..cfd127bde1c --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ListMethods.pm @@ -0,0 +1,24 @@ +use strict; +use warnings; + +package Test::Deep::ListMethods; + +use base 'Test::Deep::Methods'; + +sub call_method +{ + my $self = shift; + + return [$self->SUPER::call_method(@_)]; +} + +sub render_stack +{ + my $self = shift; + + my $var = $self->SUPER::render_stack(@_); + + return "[$var]"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm new file mode 100755 index 00000000000..982b8510857 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/MM.pm @@ -0,0 +1,64 @@ +use strict; +use warnings; + +package Test::Deep::MM; + +sub import +{ + my $self = shift; + + my ($pkg) = caller(); + my $mpkg = $pkg."::Methods"; + foreach my $attr (@_) + { + if ($attr =~ /^[a-z]/) + { + no strict 'refs'; + *{$mpkg."::$attr"} = \&{$attr}; + } + else + { + my $get_name = $mpkg."::get$attr"; + my $set_name = $mpkg."::set$attr"; + my $get_sub = sub { + return $_[0]->{$attr}; + }; + my $set_sub = sub { + return $_[0]->{$attr} = $_[1]; + }; + + { + no strict 'refs'; + *$get_name = $get_sub; + *$set_name = $set_sub; + push(@{$pkg."::ISA"}, $mpkg); + } + } + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->init(@_); + + return $self; +} + +sub init +{ + my $self = shift; + + while (@_) + { + my $name = shift || confess("No name"); + + my $method = "set$name"; + $self->$method(shift); + } +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm new file mode 100755 index 00000000000..9d71982af29 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Methods.pm @@ -0,0 +1,78 @@ +use strict; +use warnings; + +package Test::Deep::Methods; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + # get them all into [$name,@args] => $value format + my @methods; + while (@_) + { + my $name = shift; + my $value = shift; + push(@methods, + [ + ref($name) ? $name : [ $name ], + $value + ] + ); + } + $self->{methods} = \@methods; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $data = $self->data; + + foreach my $method (@{$self->{methods}}) + { + $data->{method} = $method; + + my ($call, $exp_res) = @$method; + my ($name) = @$call; + + my $got_res = UNIVERSAL::can($got, $name) ? + $self->call_method($got, $call) : + $Test::Deep::DNE; + + next if Test::Deep::descend($got_res, $exp_res); + + return 0; + } + + return 1; +} + +sub call_method +{ + my $self = shift; + my ($got, $call) = @_; + my ($name, @args) = @$call; + + return $got->$name(@args); +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + my $method = $data->{method}; + my ($call, $expect) = @$method; + my ($name, @args) = @$call; + + my $args = @args ? "(".join(", ", @args).")" : ""; + $var .= "->$name$args"; + + return $var; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm new file mode 100755 index 00000000000..754c2379443 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/NoTest.pm @@ -0,0 +1,41 @@ +use strict; +use warnings; + +# this is for people who don't want Test::Builder to be loaded but want to +# use eq_deeply. It's a bit hacky... + +package Test::Deep::NoTest; + +use vars qw( $NoTest ); + +{ + local $NoTest = 1; + require Test::Deep; +} + +sub import { + my $import = Test::Deep->can("import"); + # make the stack look like it should for use Test::Deep + my $pkg = shift; + unshift(@_, "Test::Deep"); + goto &$import; +} + +1; + +=head1 NAME + +Test::Deep::NoTest - Use Test::Deep outside of the testing framework + +=head1 SYNOPSIS + + use Test::Deep::NoTest; + + if eq_deeply($a, $b) { + print "they were deeply equal\n"; + }; + +=head1 DESCRIPTION + +This exports all the same things as Test::Deep but it does not load +Test::Builder so it can be used in ordinary non-test situations. diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm new file mode 100755 index 00000000000..d8366ff09c6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Number.pm @@ -0,0 +1,80 @@ +use strict; +use warnings; + +package Test::Deep::Number; + +use Test::Deep::Cmp; + +use Scalar::Util; + +sub init +{ + my $self = shift; + + $self->{val} = shift(@_) + 0; + $self->{tolerance} = shift; +} + +sub descend +{ + my $self = shift; + my $got = shift; + $self->data->{got_string} = $got; + { + no warnings 'numeric'; + $got += 0; + } + + $self->data->{got} = $got; + if (defined(my $tolerance = $self->{tolerance})) + { + return abs($got - $self->{val}) <= $tolerance; + } + else + { + return $got == $self->{val}; + } +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Comparing $where as a number"; +} + +sub renderGot +{ + my $self = shift; + my $val = shift; + + my $got_string = $self->data->{got_string}; + if ("$val" ne "$got_string") + { + $got_string = $self->SUPER::renderGot($got_string); + return "$val ($got_string)" + } + else + { + return $val; + } +} +sub renderExp +{ + my $self = shift; + + my $exp = $self->{val}; + + if (defined(my $tolerance = $self->{tolerance})) + { + return "$exp +/- $tolerance"; + } + else + { + return $exp; + } +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm new file mode 100755 index 00000000000..9cc3a6567b7 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Ref.pm @@ -0,0 +1,36 @@ +use strict; +use warnings; + +package Test::Deep::Ref; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub test_class +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + if ($Test::Deep::Snobby) + { + return Test::Deep::descend($got, Test::Deep::blessed(blessed($exp))); + } + else + { + return 1; + } +} + +sub test_reftype +{ + my $self = shift; + my $got = shift; + my $reftype = shift; + + return Test::Deep::descend($got, Test::Deep::reftype($reftype)); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm new file mode 100755 index 00000000000..5fc48ace245 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RefType.pm @@ -0,0 +1,46 @@ +use strict; +use warnings; + +package Test::Deep::RefType; + +use Test::Deep::Cmp; + +use Scalar::Util qw( reftype ); + +sub init +{ + my $self = shift; + + $self->{val} = shift; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + my $reftype = reftype($got); + + return Test::Deep::descend($reftype, Test::Deep::shallow($exp)); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return "reftype($var)"; +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + $self->SUPER::renderGot(reftype($got)); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm new file mode 100755 index 00000000000..3f4b9e2bfd1 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Regexp.pm @@ -0,0 +1,85 @@ +use strict; +use warnings; + +package Test::Deep::Regexp; + +use Test::Deep::Cmp; +use Test::Deep::RegexpMatches; + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = ref $val ? $val : qr/$val/; + + $self->{val} = $val; + + if (my $matches = shift) + { + $self->{matches} = Test::Deep::regexpmatches($matches, $val); + + $self->{flags} = shift || ""; + } +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $re = $self->{val}; + if (my $match_exp = $self->{matches}) + { + my $flags = $self->{flags}; + my @match_got; + if ($flags eq "g") + { + @match_got = $got =~ /$re/g; + } + else + { + @match_got = $got =~ /$re/; + } + + if (@match_got) + { + return Test::Deep::descend(\@match_got, $match_exp); + } + else + { + return 0; + } + } + else + { + return ($got =~ $re) ? 1 : 0; + } +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Using Regexp on $where"; +} + +sub render_stack1 +{ + my $self = shift; + + my $stack = shift; + return "($stack =~ $self->{regex})"; +} + +sub renderExp +{ + my $self = shift; + + return "$self->{val}"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm new file mode 100755 index 00000000000..ffee7698865 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpMatches.pm @@ -0,0 +1,51 @@ +use strict; +use warnings; + +package Test::Deep::RegexpMatches; + +use Test::Deep::Array; + +use base 'Test::Deep::Array'; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = Test::Deep::array($val) unless + blessed($val) and UNIVERSAL::isa($val, "Test::Deep::Cmp"); + + $self->{val} = $val; + $self->{regex} = shift; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + return Test::Deep::descend($got, $self->{val}); +} + +sub render_stack +{ + my $self = shift; + + my $stack = shift; + + $stack = "[$stack =~ $self->{regex}]"; + + return $stack; +# return $self->SUPER::render_stack($stack); +} + +sub reset_arrow +{ + return 1; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm new file mode 100755 index 00000000000..08fc6b5971f --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpOnly.pm @@ -0,0 +1,47 @@ +use strict; +use warnings; + +package Test::Deep::Regexp; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = ref $val ? $val : qr/$val/; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $re = $self->{val}; + + return ($got =~ $self->{val} ? 1 : 0; +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Using Regexp on $where"; +} + +sub renderExp +{ + my $self = shift; + + return "$self->{val}"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm new file mode 100755 index 00000000000..270e98909ee --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRef.pm @@ -0,0 +1,43 @@ +use strict; +use warnings; + +package Test::Deep::RegexpRef; + +use Test::Deep::Ref; +use Test::Deep::RegexpVersion; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + if ($Test::Deep::RegexpVersion::OldStyle) { + return 0 unless $self->test_class($got, "Regexp"); + return 0 unless $self->test_reftype($got, "SCALAR"); + } else { + return 0 unless $self->test_reftype($got, "REGEXP"); + } + + return Test::Deep::descend($got, Test::Deep::regexprefonly($exp)); +} + +sub renderGot +{ + my $self = shift; + + return shift().""; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm new file mode 100755 index 00000000000..c192a70953b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpRefOnly.pm @@ -0,0 +1,43 @@ +use strict; +use warnings; + +package Test::Deep::RegexpRefOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + return $got eq $exp; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "m/$var/"; +} + +sub renderGot +{ + my $self = shift; + + return shift().""; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm new file mode 100755 index 00000000000..6cbfa857ffc --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/RegexpVersion.pm @@ -0,0 +1,13 @@ +use strict; +use warnings; + +package Test::Deep::RegexpVersion; + +use vars qw( $OldStyle ); + +# Older versions of Perl treated Regexp refs as opaque scalars blessed +# into the "Regexp" class. Several bits of code need this so we +# centralise the test for that kind of version. +$OldStyle = ($] < 5.011); + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm new file mode 100755 index 00000000000..b8361668ff3 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRef.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::ScalarRef; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + my $exp = $self->{val}; + + return 0 unless $self->test_class($got); + return 0 unless $self->test_reftype($got, Scalar::Util::reftype($exp)); + return Test::Deep::descend($got, Test::Deep::scalarrefonly($exp)); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm new file mode 100755 index 00000000000..c818ae3d0b6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/ScalarRefOnly.pm @@ -0,0 +1,36 @@ +use strict; +use warnings; + +package Test::Deep::ScalarRefOnly; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + return Test::Deep::descend($$got, $$exp); +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "\${$var}"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm new file mode 100755 index 00000000000..b90f1d2da75 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Set.pm @@ -0,0 +1,185 @@ +use strict; +use warnings; + +package Test::Deep::Set; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{IgnoreDupes} = shift; + $self->{SubSup} = shift; + + $self->{val} = []; + + $self->add(@_); +} + +sub descend +{ + my $self = shift; + my $d1 = shift; + + my $d2 = $self->{val}; + + my $IgnoreDupes = $self->{IgnoreDupes}; + + my $data = $self->data; + + my $SubSup = $self->{SubSup}; + + my $type = $IgnoreDupes ? "Set" : "Bag"; + + my $diag; + + if (ref $d1 ne 'ARRAY') + { + my $got = Test::Deep::render_val($d1); + $diag = <<EOM; +got : $got +expect : An array to use as a $type +EOM + } + + if (not $diag) + { + my @got = @$d1; + my @missing; + foreach my $expect (@$d2) + { + my $found = 0; + + for (my $i = $#got; $i >= 0; $i--) + { + if (Test::Deep::eq_deeply_cache($got[$i], $expect)) + { + $found = 1; + splice(@got, $i, 1); + + last unless $IgnoreDupes; + } + } + + push(@missing, $expect) unless $found; + } + + + my @diags; + if (@missing and $SubSup ne "sub") + { + push(@diags, "Missing: ".nice_list(\@missing)); + } + + if (@got and $SubSup ne "sup") + { + my $got = __PACKAGE__->new($IgnoreDupes, "", @got); + push(@diags, "Extra: ".nice_list($got->{val})); + } + + $diag = join("\n", @diags); + } + + if ($diag) + { + $data->{diag} = $diag; + + return 0; + } + else + { + return 1; + } +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $type = $self->{IgnoreDupes} ? "Set" : "Bag"; + $type = "Sub$type" if $self->{SubSup} eq "sub"; + $type = "Super$type" if $self->{SubSup} eq "sup"; + + my $error = $last->{diag}; + my $diag = <<EOM; +Comparing $where as a $type +$error +EOM + + return $diag; +} + +sub add +{ + # this takes an array. + + # For each element A of the array, it looks for an element, B, already in + # the set which are deeply equal to A. If no matching B is found then A is + # added to the set. If a B is found and IgnoreDupes is true, then A will + # be discarded, if IgnoreDupes is false, then B will be added to the set + # again. + + my $self = shift; + + my @array = @_; + + my $IgnoreDupes = $self->{IgnoreDupes}; + + my $already = $self->{val}; + + local $Test::Deep::Expects = 1; + foreach my $new_elem (@array) + { + my $want_push = 1; + my $push_this = $new_elem; + foreach my $old_elem (@$already) + { + if (Test::Deep::eq_deeply($new_elem, $old_elem)) + { + $push_this = $old_elem; + $want_push = ! $IgnoreDupes; + last; + } + } + push(@$already, $push_this) if $want_push; + } + + # so we can compare 2 Test::Deep::Set objects using array comparison + + @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already; +} + +sub nice_list +{ + my $list = shift; + + my @scalars = grep ! ref $_, @$list; + my $refs = grep ref $_, @$list; + + my @ref_string = "$refs reference" if $refs; + $ref_string[0] .= "s" if $refs > 1; + + # sort them so we can predict the diagnostic output + + return join(", ", + (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars), + @ref_string + ); +} + +sub compare +{ + my $self = shift; + + my $other = shift; + + return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes}; + + # this works (kind of) because the the arrays are sorted + + return Test::Deep::descend($self->{val}, $other->{val}); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm new file mode 100755 index 00000000000..11f252cd5f8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Shallow.pm @@ -0,0 +1,51 @@ +use strict; +use warnings; + +package Test::Deep::Shallow; + +use Test::Deep::Cmp; + +use Scalar::Util qw( refaddr ); + +sub init +{ + my $self = shift; + + my $val = shift; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + my $exp = $self->{val}; + + my $ok; + + if (!defined $got and !defined $exp) + { + $ok = 1; + } + elsif (defined $got xor defined $exp) + { + $ok = 0; + } + elsif (ref $got and ref $exp) + { + $ok = refaddr($got) == refaddr($exp); + } + elsif (ref $got xor ref $exp) + { + $ok = 0; + } + else + { + $ok = $got eq $exp; + } + + return $ok; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm new file mode 100755 index 00000000000..4faec7a87b4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/Stack.pm @@ -0,0 +1,84 @@ +use strict; +use warnings; + +package Test::Deep::Stack; + +use Carp qw( confess ); + +use Test::Deep::MM qw( new init Stack Arrow ); + +sub init +{ + my $self = shift; + + $self->SUPER::init(@_); + + $self->setStack([]) unless $self->getStack; +} + +sub push +{ + my $self = shift; + + push(@{$self->getStack}, @_); +} + +sub pop +{ + my $self = shift; + + return pop @{$self->getStack}; +} + +sub render +{ + my $self = shift; + my $var = shift; + + my $stack = $self->getStack; + + $self->setArrow(0); + + foreach my $data (@$stack) + { + my $exp = $data->{exp}; + if (UNIVERSAL::isa($exp, "Test::Deep::Cmp")) + { + $var = $exp->render_stack($var, $data); + + $self->setArrow(0) if $exp->reset_arrow; + } + else + { + confess "Don't know how to render '$exp'"; + } + } + + return $var; +} + +sub getLast +{ + my $self = shift; + + return $self->getStack->[-1]; +} + +sub incArrow +{ + my $self = shift; + + my $a = $self->getArrow; + $self->setArrow($a + 1); + + return $a; +} + +sub length +{ + my $self = shift; + + return @{$self->getStack} + 0; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm new file mode 100755 index 00000000000..217787e5601 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/String.pm @@ -0,0 +1,34 @@ +use strict; +use warnings; + +package Test::Deep::String; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{val} = shift; +} + +sub descend +{ + my $self = shift; + my $got = shift().""; + + $self->data->{got} = $got; + + return $got eq $self->{val}; +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Comparing $where as a string"; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm b/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm new file mode 100755 index 00000000000..4dfafdaa159 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Exception.pm @@ -0,0 +1,464 @@ +use strict; +use warnings; + +package Test::Exception; +use Test::Builder; +use Sub::Uplevel qw( uplevel ); +use base qw( Exporter ); + +our $VERSION = '0.29'; +our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and); + +my $Tester = Test::Builder->new; + +sub import { + my $self = shift; + if ( @_ ) { + my $package = caller; + $Tester->exported_to( $package ); + $Tester->plan( @_ ); + }; + $self->export_to_level( 1, $self, $_ ) foreach @EXPORT; +} + +=head1 NAME + +Test::Exception - Test exception based code + +=head1 SYNOPSIS + + use Test::More tests => 5; + use Test::Exception; + + # or if you don't need Test::More + + use Test::Exception tests => 5; + + # then... + + # Check that the stringified exception matches given regex + throws_ok { $foo->method } qr/division by zero/, 'zero caught okay'; + + # Check an exception of the given class (or subclass) is thrown + throws_ok { $foo->method } 'Error::Simple', 'simple error thrown'; + + # all Test::Exceptions subroutines are guaranteed to preserve the state + # of $@ so you can do things like this after throws_ok and dies_ok + like $@, 'what the stringified exception should look like'; + + # Check that something died - we do not care why + dies_ok { $foo->method } 'expecting to die'; + + # Check that something did not die + lives_ok { $foo->method } 'expecting to live'; + + # Check that a test runs without an exception + lives_and { is $foo->method, 42 } 'method is 42'; + + # or if you don't like prototyped functions + + throws_ok( sub { $foo->method }, qr/division by zero/, + 'zero caught okay' ); + throws_ok( sub { $foo->method }, 'Error::Simple', + 'simple error thrown' ); + dies_ok( sub { $foo->method }, 'expecting to die' ); + lives_ok( sub { $foo->method }, 'expecting to live' ); + lives_and( sub { is $foo->method, 42 }, 'method is 42' ); + + +=head1 DESCRIPTION + +This module provides a few convenience methods for testing exception based code. It is built with +L<Test::Builder> and plays happily with L<Test::More> and friends. + +If you are not already familiar with L<Test::More> now would be the time to go take a look. + +You can specify the test plan when you C<use Test::Exception> in the same way as C<use Test::More>. +See L<Test::More> for details. + +NOTE: Test::Exception only checks for exceptions. It will ignore other methods of stopping +program execution - including exit(). If you have an exit() in evalled code Test::Exception +will not catch this with any of its testing functions. + +=cut + +sub _quiet_caller (;$) { ## no critic Prototypes + my $height = $_[0]; + $height++; + if( wantarray and !@_ ) { + return (CORE::caller($height))[0..2]; + } + else { + return CORE::caller($height); + } +} + +sub _try_as_caller { + my $coderef = shift; + + # local works here because Sub::Uplevel has already overridden caller + local *CORE::GLOBAL::caller; + { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; } + + eval { uplevel 3, $coderef }; + return $@; +}; + + +sub _is_exception { + my $exception = shift; + return ref $exception || $exception ne ''; +}; + + +sub _exception_as_string { + my ( $prefix, $exception ) = @_; + return "$prefix normal exit" unless _is_exception( $exception ); + my $class = ref $exception; + $exception = "$class ($exception)" + if $class && "$exception" !~ m/^\Q$class/; + chomp $exception; + return "$prefix $exception"; +}; + + +=over 4 + +=item B<throws_ok> + +Tests to see that a specific exception is thrown. throws_ok() has two forms: + + throws_ok BLOCK REGEX, TEST_DESCRIPTION + throws_ok BLOCK CLASS, TEST_DESCRIPTION + +In the first form the test passes if the stringified exception matches the give regular expression. For example: + + throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file'; + +If your perl does not support C<qr//> you can also pass a regex-like string, for example: + + throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file'; + +The second form of throws_ok() test passes if the exception is of the same class as the one supplied, or a subclass of that class. For example: + + throws_ok { $foo->bar } "Error::Simple", 'simple error'; + +Will only pass if the C<bar> method throws an Error::Simple exception, or a subclass of an Error::Simple exception. + +You can get the same effect by passing an instance of the exception you want to look for. The following is equivalent to the previous example: + + my $SIMPLE = Error::Simple->new; + throws_ok { $foo->bar } $SIMPLE, 'simple error'; + +Should a throws_ok() test fail it produces appropriate diagnostic messages. For example: + + not ok 3 - simple error + # Failed test (test.t at line 48) + # expecting: Error::Simple exception + # found: normal exit + +Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly: + + throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' ); + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +A description of the exception being checked is used if no optional test description is passed. + +=cut + + +sub throws_ok (&$;$) { + my ( $coderef, $expecting, $description ) = @_; + unless (defined $expecting) { + require Carp; + Carp::croak( "throws_ok: must pass exception class/object or regex" ); + } + $description = _exception_as_string( "threw", $expecting ) + unless defined $description; + my $exception = _try_as_caller( $coderef ); + my $regex = $Tester->maybe_regex( $expecting ); + my $ok = $regex + ? ( $exception =~ m/$regex/ ) + : eval { + $exception->isa( ref $expecting ? ref $expecting : $expecting ) + }; + $Tester->ok( $ok, $description ); + unless ( $ok ) { + $Tester->diag( _exception_as_string( "expecting:", $expecting ) ); + $Tester->diag( _exception_as_string( "found:", $exception ) ); + }; + $@ = $exception; + return $ok; +}; + + +=item B<dies_ok> + +Checks that a piece of code dies, rather than returning normally. For example: + + sub div { + my ( $a, $b ) = @_; + return $a / $b; + }; + + dies_ok { div( 1, 0 ) } 'divide by zero detected'; + + # or if you don't like prototypes + dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' ); + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +Remember: This test will pass if the code dies for any reason. If you care about the reason it might be more sensible to write a more specific test using throws_ok(). + +The test description is optional, but recommended. + +=cut + +sub dies_ok (&;$) { + my ( $coderef, $description ) = @_; + my $exception = _try_as_caller( $coderef ); + my $ok = $Tester->ok( _is_exception($exception), $description ); + $@ = $exception; + return $ok; +} + + +=item B<lives_ok> + +Checks that a piece of code doesn't die. This allows your test script to continue, rather than aborting if you get an unexpected exception. For example: + + sub read_file { + my $file = shift; + local $/; + open my $fh, '<', $file or die "open failed ($!)\n"; + $file = <FILE>; + return $file; + }; + + my $file; + lives_ok { $file = read_file('test.txt') } 'file read'; + + # or if you don't like prototypes + lives_ok( sub { $file = read_file('test.txt') }, 'file read' ); + +Should a lives_ok() test fail it produces appropriate diagnostic messages. For example: + + not ok 1 - file read + # Failed test (test.t at line 15) + # died: open failed (No such file or directory) + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +The test description is optional, but recommended. + +=cut + +sub lives_ok (&;$) { + my ( $coderef, $description ) = @_; + my $exception = _try_as_caller( $coderef ); + my $ok = $Tester->ok( ! _is_exception( $exception ), $description ); + $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok; + $@ = $exception; + return $ok; +} + + +=item B<lives_and> + +Run a test that may throw an exception. For example, instead of doing: + + my $file; + lives_ok { $file = read_file('answer.txt') } 'read_file worked'; + is $file, "42", 'answer was 42'; + +You can use lives_and() like this: + + lives_and { is read_file('answer.txt'), "42" } 'answer is 42'; + # or if you don't like prototypes + lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42'); + +Which is the same as doing + + is read_file('answer.txt'), "42\n", 'answer is 42'; + +unless C<read_file('answer.txt')> dies, in which case you get the same kind of error as lives_ok() + + not ok 1 - answer is 42 + # Failed test (test.t at line 15) + # died: open failed (No such file or directory) + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +The test description is optional, but recommended. + +=cut + +sub lives_and (&;$) { + my ( $test, $description ) = @_; + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ok = \&Test::Builder::ok; + no warnings; + local *Test::Builder::ok = sub { + $_[2] = $description unless defined $_[2]; + $ok->(@_); + }; + use warnings; + eval { $test->() } and return 1; + }; + my $exception = $@; + if ( _is_exception( $exception ) ) { + $Tester->ok( 0, $description ); + $Tester->diag( _exception_as_string( "died:", $exception ) ); + }; + $@ = $exception; + return; +} + +=back + + +=head1 SKIPPING TEST::EXCEPTION TESTS + +Sometimes we want to use Test::Exception tests in a test suite, but don't want to force the user to have Test::Exception installed. One way to do this is to skip the tests if Test::Exception is absent. You can do this with code something like this: + + use strict; + use warnings; + use Test::More; + + BEGIN { + eval "use Test::Exception"; + plan skip_all => "Test::Exception needed" if $@; + } + + plan tests => 2; + # ... tests that need Test::Exception ... + +Note that we load Test::Exception in a C<BEGIN> block ensuring that the subroutine prototypes are in place before the rest of the test script is compiled. + + +=head1 BUGS + +There are some edge cases in Perl's exception handling where Test::Exception will miss exceptions +thrown in DESTROY blocks. See the RT bug L<http://rt.cpan.org/Ticket/Display.html?id=24678> for +details, along with the t/edge-cases.t in the distribution test suite. These will be addressed in +a future Test::Exception release. + +If you find any more bugs please let me know by e-mail, or report the problem with +L<http://rt.cpan.org/>. + + +=head1 COMMUNITY + +=over 4 + +=item perl-qa + +If you are interested in testing using Perl I recommend you visit L<http://qa.perl.org/> and join the excellent perl-qa mailing list. See L<http://lists.perl.org/showlist.cgi?name=perl-qa> for details on how to subscribe. + +=item perlmonks + +You can find users of Test::Exception, including the module author, on L<http://www.perlmonks.org/>. Feel free to ask questions on Test::Exception there. + +=item CPAN::Forum + +The CPAN Forum is a web forum for discussing Perl's CPAN modules. The Test::Exception forum can be found at L<http://www.cpanforum.com/dist/Test-Exception>. + +=item AnnoCPAN + +AnnoCPAN is a web site that allows community annotations of Perl module documentation. The Test::Exception annotations can be found at L<http://annocpan.org/~ADIE/Test-Exception/>. + +=back + + +=head1 TO DO + +If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know. + +You can see my current to do list at L<http://adrianh.tadalist.com/lists/public/15421>, with an RSS feed of changes at L<http://adrianh.tadalist.com/lists/feed_public/15421>. + + +=head1 ACKNOWLEDGMENTS + +Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible. + +Thanks to +Adam Kennedy, +Andy Lester, +Aristotle Pagaltzis, +Ben Prew, +Cees Hek, +Chris Dolan, +chromatic, +Curt Sampson, +David Cantrell, +David Golden, +David Wheeler, +Janek Schleicher, +Jim Keenan, +Jos I. Boumans, +Joshua ben Jore, +Jost Krieger, +Mark Fowler, +Michael G Schwern, +Nadim Khemir, +Paul McCann, +Perrin Harkins, +Peter Scott, +Ricardo Signes, +Rob Muhlestein +Scott R. Godin, +Steve Purkis, +Steve, +Tim Bunce, +and various anonymous folk for comments, suggestions, bug reports and patches. + + +=head1 AUTHOR + +Adrian Howard <adrianh@quietstars.com> + +If you can spare the time, please drop me a line if you find this module useful. + + +=head1 SEE ALSO + +=over 4 + +=item L<http://del.icio.us/tag/Test::Exception> + +Delicious links on Test::Exception. + +=item L<Test::Warn> & L<Test::NoWarnings> + +Modules to help test warnings. + +=item L<Test::Builder> + +Support module for building test libraries. + +=item L<Test::Simple> & L<Test::More> + +Basic utilities for writing tests. + +=item L<http://qa.perl.org/test-modules.html> + +Overview of some of the many testing modules available on CPAN. + +=item L<http://del.icio.us/tag/perl+testing> + +Delicious links on perl testing. + +=back + + +=head1 LICENCE + +Copyright 2002-2007 Adrian Howard, All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm b/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm new file mode 100755 index 00000000000..4e026ce2b36 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Harness.pm @@ -0,0 +1,591 @@ +package Test::Harness; + +require 5.00405; + +use strict; + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Harness (); +use TAP::Parser::Aggregator (); +use TAP::Parser::Source (); +use TAP::Parser::SourceHandler::Perl (); + +use TAP::Parser::Utils qw( split_shell ); + +use Config; +use Exporter; + +# TODO: Emulate at least some of these +use vars qw( + $VERSION + @ISA @EXPORT @EXPORT_OK + $Verbose $Switches $Debug + $verbose $switches $debug + $Columns + $Color + $Directives + $Timer + $Strap + $HarnessSubclass + $has_time_hires + $IgnoreExit +); + +# $ML $Last_ML_Print + +BEGIN { + eval q{use Time::HiRes 'time'}; + $has_time_hires = !$@; +} + +=head1 NAME + +Test::Harness - Run Perl standard test scripts with statistics + +=head1 VERSION + +Version 3.20 + +=cut + +$VERSION = '3.20'; + +# Backwards compatibility for exportable variable names. +*verbose = *Verbose; +*switches = *Switches; +*debug = *Debug; + +$ENV{HARNESS_ACTIVE} = 1; +$ENV{HARNESS_VERSION} = $VERSION; + +END { + + # For VMS. + delete $ENV{HARNESS_ACTIVE}; + delete $ENV{HARNESS_VERSION}; +} + +@ISA = ('Exporter'); +@EXPORT = qw(&runtests); +@EXPORT_OK = qw(&execute_tests $verbose $switches); + +$Verbose = $ENV{HARNESS_VERBOSE} || 0; +$Debug = $ENV{HARNESS_DEBUG} || 0; +$Switches = '-w'; +$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; +$Columns--; # Some shells have trouble with a full line of text. +$Timer = $ENV{HARNESS_TIMER} || 0; +$Color = $ENV{HARNESS_COLOR} || 0; +$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0; + +=head1 SYNOPSIS + + use Test::Harness; + + runtests(@test_files); + +=head1 DESCRIPTION + +Although, for historical reasons, the L<Test::Harness> distribution +takes its name from this module it now exists only to provide +L<TAP::Harness> with an interface that is somewhat backwards compatible +with L<Test::Harness> 2.xx. If you're writing new code consider using +L<TAP::Harness> directly instead. + +Emulation is provided for C<runtests> and C<execute_tests> but the +pluggable 'Straps' interface that previous versions of L<Test::Harness> +supported is not reproduced here. Straps is now available as a stand +alone module: L<Test::Harness::Straps>. + +See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this +distribution. + +=head1 FUNCTIONS + +The following functions are available. + +=head2 runtests( @test_files ) + +This runs all the given I<@test_files> and divines whether they passed +or failed based on their output to STDOUT (details above). It prints +out each individual test which failed along with a summary report and +a how long it all took. + +It returns true if everything was ok. Otherwise it will C<die()> with +one of the messages in the DIAGNOSTICS section. + +=cut + +sub _has_taint { + my $test = shift; + return TAP::Parser::SourceHandler::Perl->get_taint( + TAP::Parser::Source->shebang($test) ); +} + +sub _aggregate { + my ( $harness, $aggregate, @tests ) = @_; + + # Don't propagate to our children + local $ENV{HARNESS_OPTIONS}; + + _apply_extra_INC($harness); + _aggregate_tests( $harness, $aggregate, @tests ); +} + +# Make sure the child seens all the extra junk in @INC +sub _apply_extra_INC { + my $harness = shift; + + $harness->callback( + parser_args => sub { + my ( $args, $test ) = @_; + push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); + } + ); +} + +sub _aggregate_tests { + my ( $harness, $aggregate, @tests ) = @_; + $aggregate->start(); + $harness->aggregate_tests( $aggregate, @tests ); + $aggregate->stop(); + +} + +sub runtests { + my @tests = @_; + + # shield against -l + local ( $\, $, ); + + my $harness = _new_harness(); + my $aggregate = TAP::Parser::Aggregator->new(); + + _aggregate( $harness, $aggregate, @tests ); + + $harness->formatter->summary($aggregate); + + my $total = $aggregate->total; + my $passed = $aggregate->passed; + my $failed = $aggregate->failed; + + my @parsers = $aggregate->parsers; + + my $num_bad = 0; + for my $parser (@parsers) { + $num_bad++ if $parser->has_problems; + } + + die(sprintf( + "Failed %d/%d test programs. %d/%d subtests failed.\n", + $num_bad, scalar @parsers, $failed, $total + ) + ) if $num_bad; + + return $total && $total == $passed; +} + +sub _canon { + my @list = sort { $a <=> $b } @_; + my @ranges = (); + my $count = scalar @list; + my $pos = 0; + + while ( $pos < $count ) { + my $end = $pos + 1; + $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; + push @ranges, ( $end == $pos + 1 ) + ? $list[$pos] + : join( '-', $list[$pos], $list[ $end - 1 ] ); + $pos = $end; + } + + return join( ' ', @ranges ); +} + +sub _new_harness { + my $sub_args = shift || {}; + + my ( @lib, @switches ); + my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ); + while ( my $opt = shift @opt ) { + if ( $opt =~ /^ -I (.*) $ /x ) { + push @lib, length($1) ? $1 : shift @opt; + } + else { + push @switches, $opt; + } + } + + # Do things the old way on VMS... + push @lib, _filtered_inc() if IS_VMS; + + # If $Verbose isn't numeric default to 1. This helps core. + my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 ); + + my $args = { + timer => $Timer, + directives => $Directives, + lib => \@lib, + switches => \@switches, + color => $Color, + verbosity => $verbosity, + ignore_exit => $IgnoreExit, + }; + + $args->{stdout} = $sub_args->{out} + if exists $sub_args->{out}; + + if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { + for my $opt ( split /:/, $env_opt ) { + if ( $opt =~ /^j(\d*)$/ ) { + $args->{jobs} = $1 || 9; + } + elsif ( $opt eq 'c' ) { + $args->{color} = 1; + } + else { + die "Unknown HARNESS_OPTIONS item: $opt\n"; + } + } + } + + my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; + return TAP::Harness->_construct( $class, $args ); +} + +# Get the parts of @INC which are changed from the stock list AND +# preserve reordering of stock directories. +sub _filtered_inc { + my @inc = grep { !ref } @INC; #28567 + + if (IS_VMS) { + + # VMS has a 255-byte limit on the length of %ENV entries, so + # toss the ones that involve perl_root, the install location + @inc = grep !/perl_root/i, @inc; + + } + elsif (IS_WIN32) { + + # Lose any trailing backslashes in the Win32 paths + s/[\\\/]+$// for @inc; + } + + my @default_inc = _default_inc(); + + my @new_inc; + my %seen; + for my $dir (@inc) { + next if $seen{$dir}++; + + if ( $dir eq ( $default_inc[0] || '' ) ) { + shift @default_inc; + } + else { + push @new_inc, $dir; + } + + shift @default_inc while @default_inc and $seen{ $default_inc[0] }; + } + + return @new_inc; +} + +{ + + # Cache this to avoid repeatedly shelling out to Perl. + my @inc; + + sub _default_inc { + return @inc if @inc; + + local $ENV{PERL5LIB}; + local $ENV{PERLLIB}; + + my $perl = $ENV{HARNESS_PERL} || $^X; + + # Avoid using -l for the benefit of Perl 6 + chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); + return @inc; + } +} + +sub _check_sequence { + my @list = @_; + my $prev; + while ( my $next = shift @list ) { + return if defined $prev && $next <= $prev; + $prev = $next; + } + + return 1; +} + +sub execute_tests { + my %args = @_; + + my $harness = _new_harness( \%args ); + my $aggregate = TAP::Parser::Aggregator->new(); + + my %tot = ( + bonus => 0, + max => 0, + ok => 0, + bad => 0, + good => 0, + files => 0, + tests => 0, + sub_skipped => 0, + todo => 0, + skipped => 0, + bench => undef, + ); + + # Install a callback so we get to see any plans the + # harness executes. + $harness->callback( + made_parser => sub { + my $parser = shift; + $parser->callback( + plan => sub { + my $plan = shift; + if ( $plan->directive eq 'SKIP' ) { + $tot{skipped}++; + } + } + ); + } + ); + + _aggregate( $harness, $aggregate, @{ $args{tests} } ); + + $tot{bench} = $aggregate->elapsed; + my @tests = $aggregate->descriptions; + + # TODO: Work out the circumstances under which the files + # and tests totals can differ. + $tot{files} = $tot{tests} = scalar @tests; + + my %failedtests = (); + my %todo_passed = (); + + for my $test (@tests) { + my ($parser) = $aggregate->parsers($test); + + my @failed = $parser->failed; + + my $wstat = $parser->wait; + my $estat = $parser->exit; + my $planned = $parser->tests_planned; + my @errors = $parser->parse_errors; + my $passed = $parser->passed; + my $actual_passed = $parser->actual_passed; + + my $ok_seq = _check_sequence( $parser->actual_passed ); + + # Duplicate exit, wait status semantics of old version + $estat ||= '' unless $wstat; + $wstat ||= ''; + + $tot{max} += ( $planned || 0 ); + $tot{bonus} += $parser->todo_passed; + $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; + $tot{sub_skipped} += $parser->skipped; + $tot{todo} += $parser->todo; + + if ( @failed || $estat || @errors ) { + $tot{bad}++; + + my $huh_planned = $planned ? undef : '??'; + my $huh_errors = $ok_seq ? undef : '??'; + + $failedtests{$test} = { + 'canon' => $huh_planned + || $huh_errors + || _canon(@failed) + || '??', + 'estat' => $estat, + 'failed' => $huh_planned + || $huh_errors + || scalar @failed, + 'max' => $huh_planned || $planned, + 'name' => $test, + 'wstat' => $wstat + }; + } + else { + $tot{good}++; + } + + my @todo = $parser->todo_passed; + if (@todo) { + $todo_passed{$test} = { + 'canon' => _canon(@todo), + 'estat' => $estat, + 'failed' => scalar @todo, + 'max' => scalar $parser->todo, + 'name' => $test, + 'wstat' => $wstat + }; + } + } + + return ( \%tot, \%failedtests, \%todo_passed ); +} + +=head2 execute_tests( tests => \@test_files, out => \*FH ) + +Runs all the given C<@test_files> (just like C<runtests()>) but +doesn't generate the final report. During testing, progress +information will be written to the currently selected output +filehandle (usually C<STDOUT>), or to the filehandle given by the +C<out> parameter. The I<out> is optional. + +Returns a list of two values, C<$total> and C<$failed>, describing the +results. C<$total> is a hash ref summary of all the tests run. Its +keys and values are this: + + bonus Number of individual todo tests unexpectedly passed + max Number of individual tests ran + ok Number of individual tests passed + sub_skipped Number of individual tests skipped + todo Number of individual todo tests + + files Number of test files ran + good Number of test files passed + bad Number of test files failed + tests Number of test files originally given + skipped Number of test files skipped + +If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've +got a successful test. + +C<$failed> is a hash ref of all the test scripts that failed. Each key +is the name of a test script, each value is another hash representing +how that script failed. Its keys are these: + + name Name of the test which failed + estat Script's exit value + wstat Script's wait status + max Number of individual tests + failed Number which failed + canon List of tests which failed (as string). + +C<$failed> should be empty if everything passed. + +=cut + +1; +__END__ + +=head1 EXPORT + +C<&runtests> is exported by C<Test::Harness> by default. + +C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are +exported upon request. + +=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS + +C<Test::Harness> sets these before executing the individual tests. + +=over 4 + +=item C<HARNESS_ACTIVE> + +This is set to a true value. It allows the tests to determine if they +are being executed through the harness or by any other means. + +=item C<HARNESS_VERSION> + +This is the version of C<Test::Harness>. + +=back + +=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS + +=over 4 + +=item C<HARNESS_TIMER> + +Setting this to true will make the harness display the number of +milliseconds each test took. You can also use F<prove>'s C<--timer> +switch. + +=item C<HARNESS_VERBOSE> + +If true, C<Test::Harness> will output the verbose results of running +its tests. Setting C<$Test::Harness::verbose> will override this, +or you can use the C<-v> switch in the F<prove> utility. + +=item C<HARNESS_OPTIONS> + +Provide additional options to the harness. Currently supported options are: + +=over + +=item C<< j<n> >> + +Run <n> (default 9) parallel jobs. + +=item C<< c >> + +Try to color output. See L<TAP::Formatter::Base/"new">. + +=back + +Multiple options may be separated by colons: + + HARNESS_OPTIONS=j9:c make test + +=item C<HARNESS_SUBCLASS> + +Specifies a TAP::Harness subclass to be used in place of TAP::Harness. + +=back + +=head1 Taint Mode + +Normally when a Perl program is run in taint mode the contents of the +C<PERL5LIB> environment variable do not appear in C<@INC>. + +Because C<PERL5LIB> is often used during testing to add build +directories to C<@INC> C<Test::Harness> passes the names of any +directories found in C<PERL5LIB> as -I switches. The net effect of this +is that C<PERL5LIB> is honoured even in taint mode. + +=head1 SEE ALSO + +L<TAP::Harness> + +=head1 BUGS + +Please report any bugs or feature requests to +C<bug-test-harness at rt.cpan.org>, or through the web interface at +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be +notified, and then you'll automatically be notified of progress on your bug +as I make changes. + +=head1 AUTHORS + +Andy Armstrong C<< <andy@hexten.net> >> + +L<Test::Harness> 2.64 (maintained by Andy Lester and on which this +module is based) has this attribution: + + Either Tim Bunce or Andreas Koenig, we don't know. What we know for + sure is, that it was inspired by Larry Wall's F<TEST> script that came + with perl distributions for ages. Numerous anonymous contributors + exist. Andreas Koenig held the torch for many years, and then + Michael G Schwern. + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm b/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm new file mode 100755 index 00000000000..0a3197182de --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Manifest.pm @@ -0,0 +1,336 @@ +package Test::Manifest; +use strict; + +use warnings; +no warnings; + +use base qw(Exporter); +use vars qw(@EXPORT_OK @EXPORT $VERSION); + +use Carp qw(carp); +use File::Spec::Functions qw(catfile); + +@EXPORT = qw(run_t_manifest); +@EXPORT_OK = qw(get_t_files make_test_manifest manifest_name); + +$VERSION = '1.23'; + +my $Manifest = catfile( "t", "test_manifest" ); +my %SeenInclude = (); +my %SeenTest = (); + +require 5.006; + +sub MY::test_via_harness + { + my($self, $perl, $tests) = @_; + + return qq|\t$perl "-MTest::Manifest" | . + qq|"-e" "run_t_manifest(\$(TEST_VERBOSE), '\$(INST_LIB)', | . + qq|'\$(INST_ARCHLIB)', \$(TEST_LEVEL) )"\n|; + }; + +=head1 NAME + +Test::Manifest - interact with a t/test_manifest file + +=head1 SYNOPSIS + + # in Makefile.PL + eval "use Test::Manifest"; + + # in the file t/test_manifest, list the tests you want + # to run + +=head1 DESCRIPTION + +C<Test::Harness> assumes that you want to run all of the F<.t> files in the +F<t/> directory in ascii-betical order during C<make test> unless you say +otherwise. This leads to some interesting naming schemes for test +files to get them in the desired order. This interesting names ossify +when they get into source control, and get even more interesting as +more tests show up. + +C<Test::Manifest> overrides the default behaviour by replacing the +test_via_harness target in the Makefile. Instead of running at the +F<t/*.t> files in ascii-betical order, it looks in the F<t/test_manifest> +file to find out which tests you want to run and the order in which +you want to run them. It constructs the right value for MakeMaker to +do the right thing. + +In F<t/test_manifest>, simply list the tests that you want to run. Their +order in the file is the order in which they run. You can comment +lines with a C<#>, just like in Perl, and C<Test::Manifest> will strip +leading and trailing whitespace from each line. It also checks that +the specified file is actually in the F<t/> directory. If the file does +not exist, it does not put its name in the list of test files to run and +it will issue a warning. + +Optionally, you can add a number after the test name in test_manifest +to define sets of tests. See C<get_t_files> for more information. + +=head2 Functions + +=over 4 + +=item run_t_manifest( TEST_VERBOSE, INST_LIB, INST_ARCHLIB, TEST_LEVEL ) + +Run all of the files in t/test_manifest through Test::Harness:runtests +in the order they appear in the file. + + eval "use Test::Manifest"; + +=cut + +sub run_t_manifest + { + require Test::Harness; + require File::Spec; + + $Test::Harness::verbose = shift; + + local @INC = @INC; + unshift @INC, map { File::Spec->rel2abs($_) } @_[0,1]; + + my( $level ) = $_[2] || 0; + + print STDERR "Test::Manifest $VERSION\n" + if $Test::Harness::verbose; + + print STDERR "Level is $level\n" + if $Test::Harness::verbose; + + my @files = get_t_files( $level ); + print STDERR "Test::Manifest::test_harness found [@files]\n" + if $Test::Harness::verbose; + + Test::Harness::runtests( @files ); + } + +=item get_t_files( [LEVEL] ) + +In scalar context it returns a single string that you can use directly +in WriteMakefile(). In list context it returns a list of the files it +found in t/test_manifest. + +If a t/test_manifest file does not exist, get_t_files() returns +nothing. + +get_t_files() warns you if it can't find t/test_manifest, or if +entries start with "t/". It skips blank lines, and strips Perl +style comments from the file. + +Each line in t/test_manifest can have three parts: the test name, +the test level (a floating point number), and a comment. By default, +the test level is 1. + + test_name.t 2 #Run this only for level 2 testing + +Without an argument, get_t_files() returns all the test files it +finds. With an argument that is true (so you can't use 0 as a level) +and is a number, it skips tests with a level greater than that +argument. You can then define sets of tests and choose a set to +run. For instance, you might create a set for end users, but also +add on a set for deeper testing for developers. + +Experimentally, you can include a command to grab test names from +another file. The command starts with a C<;> to distinguish it +from a true filename. The filename (currently) is relative to the +current working directory, unlike the filenames, which are relative +to C<t/>. The filenames in the included are still relative to C<t/>. + + ;include t/file_with_other_test_names.txt + +Also experimentally, you can stop Test::Manifest from reading filenames +with the C<;skip> directive. Test::Harness will skip the filenames up to +the C<;unskip> directive (or end of file) + + run_this1 + ;skip + skip_this + ;unskip + run_this2 + +To select sets of tests, specify the level in the variable TEST_LEVEL +during `make test`. + + make test # run all tests no matter the level + make test TEST_LEVEL=2 # run all tests level 2 and below + +=cut + +sub get_t_files + { + my $upper_bound = shift; + print STDERR "# Test level is $upper_bound\n" + if $Test::Harness::verbose; + + %SeenInclude = (); + %SeenTest = (); + + carp( "$Manifest does not exist!" ) unless -e $Manifest; + my $result = _load_test_manifest($Manifest, $upper_bound); + return unless defined $result; + my @tests = @{$result}; + + return wantarray ? @tests : join " ", @tests; + } + +# Wrapper for loading test manifest files to support including other files +sub _load_test_manifest + { + my $manifest = shift; + return unless open my( $fh ), $manifest; + + my $upper_bound = shift || 0; + my @tests = (); + + LINE: while( <$fh> ) + { + s/#.*//; s/^\s+//; s/\s+$//; + + next unless $_; + + my( $command, $arg ) = split/\s+/, $_, 2; + if( ';' eq substr( $command, 0, 1 ) ) + { + if( $command eq ';include' ) + { + my $result = _include_file( $arg, $., $upper_bound ); + push @tests, @$result if defined $result; + next; + } + elsif( $command eq ';skip' ) + { + while( <$fh> ) { last if m/^;unskip/ } + next LINE; + } + else + { + croak( "Unknown directive: $command" ); + } + } + + my( $test, $level ) = ( $command, $arg ); + $level = 1 unless defined $level; + + next if( $upper_bound and $level > $upper_bound ); + + carp( "Bad value for test [$test] level [$level]\n". + "Level should be a floating-point number\n" ) + unless $level =~ m/^\d+(?:.\d+)?$/; + carp( "test file begins with t/ [$test]" ) if m|^t/|; + + $test = catfile( "t", $test ) if -e catfile( "t", $test ); + + unless( -e $test ) + { + carp( "test file [$test] does not exist! Skipping!" ); + next; + } + + # Make sure we don't include a test we've already seen + next if exists $SeenTest{$test}; + + $SeenTest{$test} = 1; + push @tests, $test; + } + + close $fh; + return \@tests; + } + +sub _include_file + { + my( $file, $line, $upper_bound ) = @_; + print STDERR "# Including file $file at line $line\n" + if $Test::Harness::verbose; + + unless( -e $file ) + { + carp( "$file does not exist" ) ; + return; + } + + if( exists $SeenInclude{$file} ) + { + carp( "$file already loaded - skipping" ) ; + return; + } + + $SeenInclude{$file} = $line; + + my $result = _load_test_manifest( $file, $upper_bound ); + return unless defined $result; + + $result; + } + + +=item make_test_manifest() + +Creates the test_manifest file in the t directory by reading +the contents of the t directory. + +TO DO: specify tests in argument lists. + +TO DO: specify files to skip. + +=cut + +sub make_test_manifest() + { + carp( "t/ directory does not exist!" ) unless -d "t"; + return unless open my( $fh ), "> $Manifest"; + + my $count = 0; + while( my $file = glob("t/*.t") ) + { + $file =~ s|^t/||; + print $fh "$file\n"; + $count++; + } + close $fh; + + return $count; + } + +=item manifest_name() + +Returns the name of the test manifest file, relative to t/ + +=cut + +sub manifest_name + { + return $Manifest; + } + +=back + +=head1 SOURCE AVAILABILITY + +This source is in Github: + + http://github.com/briandfoy/Test-Manifest/tree/master + +=head1 CREDITS + +Matt Vanderpol suggested and supplied a patch for the ;include +feature. + +=head1 AUTHOR + +brian d foy, C<< <bdfoy@cpan.org> >> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002-2009 brian d foy. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/More.pm b/Master/tlpkg/tlperl.straw/lib/Test/More.pm new file mode 100755 index 00000000000..67284874698 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/More.pm @@ -0,0 +1,1776 @@ +package Test::More; + +use 5.006; +use strict; +use warnings; + +#---- perlcritic exemptions. ----# + +# We use a lot of subroutine prototypes +## no critic (Subroutines::ProhibitSubroutinePrototypes) + +# Can't use Carp because it might cause 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"; +} + +our $VERSION = '0.94'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + done_testing + can_ok isa_ok new_ok + diag note explain + subtest + BAIL_OUT +); + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => 23; + # or + use Test::More skip_all => $reason; + # or + use Test::More; # see done_testing() + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($got eq $expected, $test_name); + + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($got, qr/expected/, $test_name); + unlike($got, qr/expected/, $test_name); + + cmp_ok($got, '==', $expected, $test_name); + + is_deeply($got_complex_structure, $expected_complex_structure, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + BAIL_OUT($why); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + +=head1 DESCRIPTION + +B<STOP!> If you're just getting started writing tests, have a look at +L<Test::Simple> first. This is a drop in replacement for Test::Simple +which you can switch to once you get the hang of basic testing. + +The purpose of this module is to provide a wide range of testing +utilities. Various ways to say "ok" with better diagnostics, +facilities to skip tests, test future features and compare complicated +data structures. While you can do almost anything with a simple +C<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 +how many tests your script is going to run to protect against premature +failure. + +The preferred way to do this is to declare a plan when you C<use Test::More>. + + use Test::More tests => 23; + +There are cases when you will not know beforehand how many tests your +script is going to run. In this case, you can declare your tests at +the end. + + use Test::More; + + ... run your tests ... + + done_testing( $number_of_tests_run ); + +Sometimes you really don't know how many tests were run, or it's too +difficult to calculate. In which case you can leave off +$number_of_tests_run. + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More skip_all => $skip_reason; + +Your script will declare a skip with the reason why you skipped and +exit immediately with a zero (success). See L<Test::Harness> for +details. + +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the plan() function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevant on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my $tb = Test::More->builder; + + return $tb->plan(@_); +} + +# This implements "use Test::More 'no_diag'" but the behavior is +# deprecated. +sub import_extra { + my $class = shift; + my $list = shift; + + my @other = (); + my $idx = 0; + 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> + + done_testing(); + done_testing($number_of_tests); + +If you don't know how many tests you're going to run, you can issue +the plan when you're done running tests. + +$number_of_tests is the same as plan(), it's the number of tests you +expected to run. You can omit this, in which case the number of tests +you ran doesn't matter, just the fact that your tests ran to +conclusion. + +This is safer than and replaces the "no_plan" plan. + +=back + +=cut + +sub done_testing { + my $tb = Test::More->builder; + $tb->done_testing(@_); +} + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, it's often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. It's optional, but highly +suggested that you use it. + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B<ok> + + ok($got eq $expected, $test_name); + +This simply evaluates any expression (C<$got eq $expected> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep !defined $_, @items, 'items populated' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B<very> strongly encourage its use. + +Should an ok() fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 'sufficient mucus' + # in foo.t at line 42. + +This is the same as Test::Simple's ok() routine. + +=cut + +sub ok ($;$) { + my( $test, $name ) = @_; + my $tb = Test::More->builder; + + return $tb->ok( $test, $name ); +} + +=item B<is> + +=item B<isnt> + + is ( $got, $expected, $test_name ); + isnt( $got, $expected, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments +with C<eq> and C<ne> respectively and use the result of that to +determine if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. ok() +cannot know what you are testing for (beyond the name), but is() and +isnt() know what the test was and why it failed. For example this +test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test 'Is foo the same as bar?' + # in foo.t at line 139. + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use is() and isnt() over ok() where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! + is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); + +This does not check if C<exists $brooklyn{tree}> is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use ok(). + + ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); + +A simple call to isnt() usually does not provide a strong test but there +are cases when you cannot say much more about a value than that it is +different from some other value: + + new_ok $obj, "Foo"; + + my $clone = $obj->clone; + isa_ok $obj, "Foo", "Foo->clone"; + + isnt $obj, $clone, "clone() produces a different object"; + +For those grammatical pedants out there, there's an C<isn't()> +function which is an alias of 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; + +=item B<like> + + like( $got, qr/expected/, $test_name ); + +Similar to ok(), like() matches $got against the regex C<qr/expected/>. + +So this: + + like($got, qr/expected/, 'this is like that'); + +is similar to: + + ok( $got =~ /expected/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (i.e. C<qr//>) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $got, '/expected/', 'this is like that' ); + +Regex options may be placed on the end (C<'/expected/i'>). + +Its advantages over ok() are similar to that of is() and 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 ); + +Works exactly as 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 ); + +Halfway between ok() and is() lies cmp_ok(). This allows you to +compare two arguments using any binary perl operator. + + # ok( $got eq $expected ); + cmp_ok( $got, 'eq', $expected, 'this eq that' ); + + # ok( $got == $expected ); + cmp_ok( $got, '==', $expected, 'this == that' ); + + # ok( $got && $expected ); + cmp_ok( $got, '&&', $expected, 'this && that' ); + ...etc... + +Its advantage over ok() is when the test fails you'll know what $got +and $expected were: + + not ok 1 + # Failed test in foo.t at line 12. + # '23' + # && + # undef + +It's also useful in those cases where you are comparing numbers and +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 +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); + can_ok($object, @methods); + +Checks to make sure the $module or $object can do these @methods +(works with functions, too). + + can_ok('Foo', qw(this that whatever)); + +is almost exactly like saying: + + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') + ); + +only without all the typing and with a better interface. Handy for +quickly testing an interface. + +No matter how many @methods you check, a single can_ok() call counts +as one test. If you desire otherwise, use: + + foreach my $meth (@methods) { + can_ok('Foo', $meth); + } + +=cut + +sub can_ok ($@) { + my( $proto, @methods ) = @_; + my $class = ref $proto || $proto; + my $tb = Test::More->builder; + + unless($class) { + my $ok = $tb->ok( 0, "->can(...)" ); + $tb->diag(' can_ok() called with empty class or reference'); + return $ok; + } + + unless(@methods) { + my $ok = $tb->ok( 0, "$class->can(...)" ); + $tb->diag(' can_ok() called with no methods'); + return $ok; + } + + my @nok = (); + foreach my $method (@methods) { + $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; + } + + my $name = (@methods == 1) ? "$class->can('$methods[0]')" : + "$class->can(...)" ; + + my $ok = $tb->ok( !@nok, $name ); + + $tb->diag( map " $class->can('$_') failed\n", @nok ); + + return $ok; +} + +=item B<isa_ok> + + isa_ok($object, $class, $object_name); + isa_ok($subclass, $class, $object_name); + isa_ok($ref, $type, $ref_name); + +Checks to see if the given C<< $object->isa($class) >>. Also checks to make +sure the object was defined in the first place. Handy for this sort +of thing: + + my $obj = Some::Module->new; + isa_ok( $obj, 'Some::Module' ); + +where you'd otherwise have to write + + my $obj = Some::Module->new; + ok( defined $obj && $obj->isa('Some::Module') ); + +to safeguard against your test script blowing up. + +You can also test a class, to make sure that it has the right ancestor: + + isa_ok( 'Vole', 'Rodent' ); + +It works on references, too: + + isa_ok( $array_ref, 'ARRAY' ); + +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + +=cut + +sub isa_ok ($$;$) { + my( $object, $class, $obj_name ) = @_; + my $tb = Test::More->builder; + + my $diag; + + if( !defined $object ) { + $obj_name = 'The thing' unless defined $obj_name; + $diag = "$obj_name isn't defined"; + } + else { + my $whatami = ref $object ? 'object' : 'class'; + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); + if($error) { + if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { + # Its an unblessed reference + $obj_name = 'The reference' unless defined $obj_name; + if( !UNIVERSAL::isa( $object, $class ) ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + elsif( $error =~ /Can't call method "isa" without a package/ ) { + # It's something that can't even be a class + $obj_name = 'The thing' unless defined $obj_name; + $diag = "$obj_name isn't a class or reference"; + } + else { + die <<WHOA; +WHOA! I tried to call ->isa on your $whatami and got some weird error. +Here's the error. +$error +WHOA + } + } + else { + $obj_name = "The $whatami" unless defined $obj_name; + if( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + } + + my $name = "$obj_name isa $class"; + my $ok; + if($diag) { + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); + } + else { + $ok = $tb->ok( 1, $name ); + } + + return $ok; +} + +=item B<new_ok> + + my $obj = new_ok( $class ); + my $obj = new_ok( $class => \@args ); + my $obj = new_ok( $class => \@args, $object_name ); + +A convenience function which combines creating an object and calling +isa_ok() on that object. + +It is basically equivalent to: + + my $obj = $class->new(@args); + isa_ok $obj, $class, $object_name; + +If @args is not given, an empty list will be used. + +This function only works on new() and it assumes 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 ||= []; + $object_name = "The object" unless defined $object_name; + + 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 { + $tb->ok( 0, "new() died" ); + $tb->diag(" Error was: $error"); + } + + return $obj; +} + +=item B<subtest> + + subtest $name => \&code; + +subtest() runs the &code as its own little test with its own plan and +its own result. The main test counts this as a single test using the +result of the whole subtest to determine if its ok or not ok. + +For example... + + use Test::More tests => 3; + + pass("First test"); + + subtest 'An example subtest' => sub { + plan tests => 2; + + pass("This is a subtest"); + pass("So is this"); + }; + + pass("Third test"); + +This would produce. + + 1..3 + ok 1 - First test + 1..2 + ok 1 - This is a subtest + ok 2 - So is this + ok 2 - An example subtest + ok 3 - Third test + +A subtest may call "skip_all". No tests will be run, but the subtest is +considered a skip. + + subtest 'skippy' => sub { + plan skip_all => 'cuz I said so'; + pass('this test will never be run'); + }; + +Returns true if the subtest passed, false otherwise. + +=cut + +sub subtest($&) { + my ($name, $subtests) = @_; + + my $tb = Test::More->builder; + return $tb->subtest(@_); +} + +=item B<pass> + +=item B<fail> + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an ok(). In this case, you can simply use pass() (to +declare the test ok) or fail (for not ok). They are synonyms for +ok(1) and 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 + +You usually want to test if the module you're testing loads ok, rather +than just vomiting if its load fails. For such purposes we have +C<use_ok> and C<require_ok>. + +=over 4 + +=item B<use_ok> + + BEGIN { use_ok($module); } + BEGIN { use_ok($module, @imports); } + +These simply use the given $module and test to make sure the load +happened ok. It's recommended that you run use_ok() inside a BEGIN +block so its functions are exported at compile-time and prototypes are +properly honored. + +If @imports are given, they are passed through to the use. So this: + + BEGIN { use_ok('Some::Module', qw(foo bar)) } + +is like doing this: + + use Some::Module qw(foo bar); + +Version numbers can be checked like so: + + # Just like "use Some::Module 1.02" + BEGIN { use_ok('Some::Module', 1.02) } + +Don't try to do this: + + BEGIN { + use_ok('Some::Module'); + + ...some code that depends on the use... + ...happening at compile time... + } + +because the notion of "compile-time" is relative. Instead, you want: + + BEGIN { use_ok('Some::Module') } + BEGIN { ...some code that depends on the use... } + + +=cut + +sub use_ok ($;@) { + my( $module, @imports ) = @_; + @imports = () unless @imports; + my $tb = Test::More->builder; + + my( $pack, $filename, $line ) = caller; + + 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; +use $module $imports[0]; +1; +USE + } + else { + $code = <<USE; +package $pack; +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 ); +} + +=item B<require_ok> + + require_ok($module); + require_ok($file); + +Like use_ok(), except it requires the $module or $file. + +=cut + +sub require_ok ($) { + my($module) = shift; + my $tb = Test::More->builder; + + my $pack = caller; + + # Try to deterine 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; +} + +=back + + +=head2 Complex data structures + +Not everything is a simple eq check or regex. There are times you +need to see if two data structures are equivalent. For these +instances Test::More provides a handful of useful functions. + +B<NOTE> I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B<is_deeply> + + is_deeply( $got, $expected, $test_name ); + +Similar to is(), except that if $got and $expected are references, it +does a deep comparison walking each data structure to see if they are +equivalent. If the two structures are different, it will display the +place where they start differing. + +is_deeply() compares the dereferenced values of references, the +references themselves (except for their type) are ignored. This means +aspects such as blessing and ties are not considered "different". + +is_deeply() currently has very limited handling of function reference +and globs. It merely checks if they have the same referent. This may +improve in the future. + +L<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(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { + return $type if UNIVERSAL::isa( $thing, $type ); + } + + return ''; +} + +=back + + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C<print STDERR>. + +=over 4 + +=item B<diag> + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C<print> @diagnostic_message is simply concatenated +together. + +Returns false, so as to preserve failure. + +Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test 'There's a foo user' + # in foo.t at line 52. + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C<ok() or diag()> with the mnemonic C<open() or +die()>. + +B<NOTE> The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it it won't +interfere with the test. + +=item B<note> + + note(@diagnostic_message); + +Like diag(), except the message will not be seen when the test is run +in a harness. It will only be visible in the verbose TAP stream. + +Handy for putting in notes which might be useful for debugging, but +don't indicate a problem. + + note("Tempfile is $tempfile"); + +=cut + +sub diag { + return Test::More->builder->diag(@_); +} + +sub note { + return Test::More->builder->note(@_); +} + +=item B<explain> + + my @dump = explain @diagnostic_message; + +Will dump the contents of any references in a human readable format. +Usually you want to pass this into C<note> or C<diag>. + +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + note explain \%args; + Some::Class->method(%args); + +=cut + +sub explain { + return Test::More->builder->explain(@_); +} + +=back + + +=head2 Conditional tests + +Sometimes running a test under certain conditions will cause the +test script to die. A certain function or method isn't implemented +(such as 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). + +For more details on the mechanics of skip and todo tests see +L<Test::Harness>. + +The way Test::More handles this is with a named block. Basically, a +block of tests which can be skipped over or made todo. It's best if I +just show you... + +=over 4 + +=item B<SKIP: BLOCK> + + SKIP: { + skip $why, $how_many if $condition; + + ...normal testing code goes here... + } + +This declares a block of tests that might be skipped, $how_many tests +there are, $why and under what $condition to skip them. An example is +the easiest way to illustrate: + + SKIP: { + eval { require HTML::Lint }; + + skip "HTML::Lint not installed", 2 if $@; + + my $lint = new HTML::Lint; + isa_ok( $lint, "HTML::Lint" ); + + $lint->parse( $html ); + is( $lint->errors, 0, "No errors found in HTML" ); + } + +If the user does not have HTML::Lint installed, the whole block of +code I<won't be run at all>. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. + +It's important that $how_many accurately reflects the number of tests +in the SKIP block so the # of tests run will match up with your plan. +If your plan is C<no_plan> $how_many is optional and will default to 1. + +It's perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C<SKIP>, or Test::More can't work its magic. + +You don't skip tests which are failing because there's a bug in your +program, or for which you don't yet have code written. For that you +use TODO. Read on. + +=cut + +## no critic (Subroutines::RequireFinalReturn) +sub skip { + my( $why, $how_many ) = @_; + my $tb = Test::More->builder; + + 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: { + local $TODO = $why if $condition; + + ...normal testing code goes here... + } + +Declares a block of tests you expect to fail and $why. Perhaps it's +because you haven't fixed a bug or haven't finished a new feature: + + TODO: { + local $TODO = "URI::Geller not finished"; + + my $card = "Eight of clubs"; + is( URI::Geller->your_card, $card, 'Is THIS your card?' ); + + my $spoon; + URI::Geller->bend_spoon; + is( $spoon, 'bent', "Spoon bending, that's original" ); + } + +With a todo block, the tests inside are expected to fail. Test::More +will run the tests normally, but print out special flags indicating +they are "todo". Test::Harness will interpret failures as being ok. +Should anything succeed, it will report it as an unexpected success. +You then know the thing you had todo is done and can remove the +TODO flag. + +The nice part about todo tests, as opposed to simply commenting out a +block of tests, is it's like having a programmatic todo list. You know +how much work is left to be done, you're aware of what bugs there are, +and you'll know immediately when they're fixed. + +Once a todo test starts succeeding, simply move it outside the block. +When the block is empty, delete it. + + +=item B<todo_skip> + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, it's best to have the tests actually run. That way +you'll know when they start passing. Sometimes this isn't possible. +Often a failing test will cause the whole program to die or hang, even +inside an C<eval BLOCK> with and using C<alarm>. In these extreme +cases you have no choice but to skip over the broken tests entirely. + +The syntax and behavior is similar to a C<SKIP: BLOCK> except the +tests will be marked as failing but todo. 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? + +B<If it's something the user might not be able to do>, use SKIP. +This includes optional modules that aren't installed, running under +an OS that doesn't have some feature (like fork() or symlinks), or maybe +you need an Internet connection and one isn't available. + +B<If it's something the programmer hasn't done yet>, use TODO. This +is for any code you haven't written yet, or bugs you have yet to fix, +but want to put tests in your testing script (always a good idea). + + +=back + + +=head2 Test control + +=over 4 + +=item B<BAIL_OUT> + + BAIL_OUT($reason); + +Indicates to the harness that things are going so badly all testing +should terminate. This includes the running any additional test scripts. + +This is typically used when testing cannot continue such as a critical +module failing to compile or a necessary external utility not being +available such as a database connection failing. + +The test will exit with 255. + +For even better control look at L<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 +actually testing functions and produce no diagnostics to help figure +out what went wrong. They were written before is_deeply() existed +because I couldn't figure out how to display a useful diff of two +arbitrary data structures. + +These functions are usually used inside an ok(). + + ok( eq_array(\@got, \@expected) ); + +C<is_deeply()> can do that better and with diagnostics. + + is_deeply( \@got, \@expected ); + +They may be deprecated in future versions. + +=over 4 + +=item B<eq_array> + + my $is_eq = eq_array(\@got, \@expected); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +sub eq_array { + local @Data_Stack = (); + _deep_check(@_); +} + +sub _eq_array { + my( $a1, $a2 ) = @_; + + if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { + warn "eq_array passed a non-array ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + my $ok = 1; + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for( 0 .. $max ) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + 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 _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; + + { + # Quiet uninitialized value warnings when comparing undefs. + no warnings 'uninitialized'; + + $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 defined. + $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); + +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; + + 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> + + my $is_eq = eq_set(\@got, \@expected); + +Similar to eq_array(), except the order of the elements is B<not> +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + + ok( eq_set(\@got, \@expected) ); + +Is better written: + + is_deeply( [sort @got], [sort @expected] ); + +B<NOTE> By historical accident, this is not a true set comparison. +While the order of elements does not matter, duplicate elements do. + +B<NOTE> eq_set() does not know how to deal with references at the top +level. The following is an example of a comparison which might not work: + + eq_set([\1, \2], [\2, \1]); + +L<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 Test::Builder 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 +same program>. + +If you simply want to do a little tweaking of how the tests behave, +you can access the underlying Test::Builder object like so: + +=over 4 + +=item B<builder> + + my $test_builder = Test::More->builder; + +Returns the Test::Builder object underlying Test::More for you to play +with. + + +=back + + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +B<NOTE> This behavior may go away in future versions. + + +=head1 CAVEATS and NOTES + +=over 4 + +=item Backwards compatibility + +Test::More works with Perls as old as 5.6.0. + + +=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. 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. + +The work around is to change the filehandles used by Test::Builder +directly. + + my $builder = Test::More->builder; + binmode $builder->output, ":utf8"; + binmode $builder->failure_output, ":utf8"; + binmode $builder->todo_output, ":utf8"; + + +=item Overloaded objects + +String overloaded objects are compared B<as strings> (or in cmp_ok()'s +case, strings or numbers as appropriate to the comparison op). This +prevents Test::More from piercing an object's interface allowing +better blackbox testing. So if a function starts returning overloaded +objects instead of bare strings your tests won't notice the +difference. This is good. + +However, it does mean that functions like is_deeply() cannot be used to +test the internals of string overloaded objects. In this case I would +suggest L<Test::Deep> which contains more flexible testing functions for +complex data structures. + + +=item Threads + +Test::More will only be aware of threads if "use threads" has been done +I<before> Test::More is loaded. This is ok: + + use threads; + use Test::More; + +This may cause problems: + + use Test::More + use threads; + +5.8.1 and above are supported. Anything below that has too many bugs. + +=back + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's Test +module. I was largely unaware of its existence when I'd first +written my own ok() routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +L<Test::Simple> if all this confuses you and you just want to write +some tests. You can upgrade to Test::More later (it's forward +compatible). + +L<Test::Harness> is the test runner and output interpreter for Perl. +It's the thing that powers C<make test> and where the C<prove> utility +comes from. + +L<Test::Legacy> tests written with Test.pm, the original testing +module, do not play well with other testing libraries. Test::Legacy +emulates the Test.pm interface and does play well with others. + +L<Test::Differences> for more ways to test complex data structures. +And it plays well with Test::More. + +L<Test::Class> is like xUnit but more perlish. + +L<Test::Deep> gives you more powerful complex data structure testing. + +L<Test::Inline> shows the idea of embedded testing. + +L<Bundle::Test> installs a whole bunch of useful test modules. + + +=head1 AUTHORS + +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 BUGS + +See F<http://rt.cpan.org> to report and view bugs. + + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/schwern/test-more/>. + + +=head1 COPYRIGHT + +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> + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm new file mode 100755 index 00000000000..17dfb1301c4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings.pm @@ -0,0 +1,305 @@ +package Test::NoWarnings; + +use 5.006; +use strict; +use warnings; +use Carp; +use Exporter (); +use Test::Builder; +use Test::NoWarnings::Warning (); + +use vars qw( $VERSION @EXPORT_OK @ISA $do_end_test ); +BEGIN { + $VERSION = '1.01'; + @ISA = 'Exporter'; + @EXPORT_OK = qw( + clear_warnings had_no_warnings warnings + ); + + # Do we add the warning test at the end? + $do_end_test = 0; +} + +my $TEST = Test::Builder->new; +my $PID = $$; +my @WARNINGS = (); + +$SIG{__WARN__} = make_catcher(\@WARNINGS); + +sub import { + $do_end_test = 1; + goto &Exporter::import; +} + +# the END block must be after the "use Test::Builder" to make sure it runs +# before Test::Builder's end block +# only run the test if there have been other tests +END { + had_no_warnings() if $do_end_test; +} + +sub make_warning { + local $SIG{__WARN__}; + + my $msg = shift; + my $warning = Test::NoWarnings::Warning->new; + + $warning->setMessage($msg); + $warning->fillTest($TEST); + $warning->fillTrace(__PACKAGE__); + + $Carp::Internal{__PACKAGE__.""}++; + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $warning->fillCarp($msg); + $Carp::Internal{__PACKAGE__.""}--; + + return $warning; +} + +# this make a subroutine which can be used in $SIG{__WARN__} +# it takes one argument, a ref to an array +# it will push the details of the warning onto the end of the array. +sub make_catcher { + my $array = shift; + + return sub { + my $msg = shift; + + $Carp::Internal{__PACKAGE__.""}++; + push(@$array, make_warning($msg)); + $Carp::Internal{__PACKAGE__.""}--; + + return $msg; + }; +} + +sub had_no_warnings { + return 0 if $$ != $PID; + + local $SIG{__WARN__}; + my $name = shift || "no warnings"; + + my $ok; + my $diag; + if ( @WARNINGS == 0 ) { + $ok = 1; + } else { + $ok = 0; + $diag = "There were ".@WARNINGS." warning(s)\n"; + $diag .= join "----------\n", map { $_->toString } @WARNINGS; + } + + $TEST->ok($ok, $name) || $TEST->diag($diag); + + return $ok; +} + +sub clear_warnings { + local $SIG{__WARN__}; + @WARNINGS = (); +} + +sub warnings { + local $SIG{__WARN__}; + return @WARNINGS; +} + +sub builder { + local $SIG{__WARN__}; + if ( @_ ) { + $TEST = shift; + } + return $TEST; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Test::NoWarnings - Make sure you didn't emit any warnings while testing + +=head1 SYNOPSIS + +For scripts that have no plan + + use Test::NoWarnings; + +that's it, you don't need to do anything else + +For scripts that look like + + use Test::More tests => x; + +change to + + use Test::More tests => x + 1; + use Test::NoWarnings; + +=head1 DESCRIPTION + +In general, your tests shouldn't produce warnings. This modules causes any +warnings to be captured and stored. It automatically adds an extra test that +will run when your script ends to check that there were no warnings. If +there were any warings, the test will give a "not ok" and diagnostics of +where, when and what the warning was, including a stack trace of what was +going on when the it occurred. + +If some of your tests B<are supposed to> produce warnings then you should be +capturing and checking them with L<Test::Warn>, that way L<Test::NoWarnings> +will not see them and so not complain. + +The test is run by an END block in Test::NoWarnings. It will not be run when +any forked children exit. + +=head1 USAGE + +Simply by using the module, you automatically get an extra test at the end +of your script that checks that no warnings were emitted. So just stick + + use Test::NoWarnings + +at the top of your script and continue as normal. + +If you want more control you can invoke the test manually at any time with +C<had_no_warnings()>. + +The warnings your test has generated so far are stored in an array. You can +look inside and clear this whenever you want with C<warnings()> and +C<clear_warnings()>, however, if you are doing this sort of thing then you +probably want to use L<Test::Warn> in combination with L<Test::NoWarnings>. + +=head1 USE vs REQUIRE + +You will almost always want to do + + use Test::NoWarnings + +If you do a C<require> rather than a C<use>, then there will be no automatic +test at the end of your script. + +=head1 OUTPUT + +If warning is captured during your test then the details will output as part +of the diagnostics. You will get: + +=over 2 + +=item o + +the number and name of the test that was executed just before the warning +(if no test had been executed these will be 0 and '') + +=item o + +the message passed to C<warn>, + +=item o + +a full dump of the stack when warn was called, courtesy of the C<Carp> +module + +=back + +=head1 EXPORTABLE FUNCTIONS + +=head2 had_no_warnings() + +This checks that there have been warnings emitted by your test scripts. +Usually you will not call this explicitly as it is called automatically when +your script finishes. + +=head2 clear_warnings() + +This will clear the array of warnings that have been captured. If the array +is empty then a call to C<had_no_warnings()> will produce a pass result. + +=head2 warnings() + +This will return the array of warnings captured so far. Each element of this +array is an object containing information about the warning. The following +methods are available on these object. + +=over 2 + +=item * + +$warn-E<gt>getMessage + +Get the message that would been printed by the warning. + +=item * + +$warn-E<gt>getCarp + +Get a stack trace of what was going on when the warning happened, this stack +trace is just a string generated by the L<Carp> module. + +=item * + +$warn-E<gt>getTrace + +Get a stack trace object generated by the L<Devel::StackTrace> module. This +will return undef if L<Devel::StackTrace> is not installed. + +=item * + +$warn-E<gt>getTest + +Get the number of the test that executed before the warning was emitted. + +=item * + +$warn-E<gt>getTestName + +Get the name of the test that executed before the warning was emitted. + +=back + +=head1 PITFALLS + +When counting your tests for the plan, don't forget to include the test that +runs automatically when your script ends. + +=head1 BUGS + +None that I know of. + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-NoWarnings> + +For other issues, contact the author. + +=head1 HISTORY + +This was previously known as L<Test::Warn::None> + +=head1 SEE ALSO + +L<Test::Builder>, L<Test::Warn> + +=head1 AUTHORS + +Fergal Daly E<lt>fergal@esatclear.ieE<gt> + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2003 - 2007 Fergal Daly. + +Some parts copyright 2010 Adam Kennedy. + +This program is free software and comes with no warranty. It is distributed +under the LGPL license + +See the file F<LGPL> included in this distribution or +F<http://www.fsf.org/licenses/licenses.html>. + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm new file mode 100755 index 00000000000..54db0bba71e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/NoWarnings/Warning.pm @@ -0,0 +1,79 @@ +package Test::NoWarnings::Warning; + +use 5.006; +use strict; +use warnings; +use Carp (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.01'; +} + +my $STACKTRACE = eval "require Devel::StackTrace" || 0; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +sub getTrace { + my $self = shift; + return $self->{Trace}; +} + +sub fillTrace { + my $self = shift; + $self->{Trace} = Devel::StackTrace->new( + ignore_class => [__PACKAGE__, @_], + ) if $STACKTRACE; +} + +sub getCarp { + $_[0]->{Carp}; +} + +sub fillCarp { + my $self = shift; + my $msg = shift; + $Carp::Internal{ __PACKAGE__ . "" }++; + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $self->{Carp} = Carp::longmess($msg); + $Carp::Internal{ __PACKAGE__ . "" }--; +} + +sub getMessage { + $_[0]->{Message}; +} + +sub setMessage { + $_[0]->{Message} = $_[1]; +} + +sub fillTest { + my $self = shift; + my $builder = shift; + my $prev_test = $builder->current_test; + $self->{Test} = $prev_test; + my @tests = $builder->details; + my $prev_test_name = $prev_test ? $tests[$prev_test - 1]->{name} : ""; + $self->{TestName} = $prev_test_name; +} + +sub getTest { + $_[0]->{Test}; +} + +sub getTestName { + $_[0]->{TestName}; +} + +sub toString { + my $self = shift; + return <<EOM; + Previous test $self->{Test} '$self->{TestName}' + $self->{Carp} +EOM +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Script.pm b/Master/tlpkg/tlperl.straw/lib/Test/Script.pm new file mode 100755 index 00000000000..734afecce71 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Script.pm @@ -0,0 +1,238 @@ +package Test::Script; + +=pod + +=head1 NAME + +Test::Script - Basic cross-platform tests for scripts + +=head1 DESCRIPTION + +The intent of this module is to provide a series of basic tests for 80% +of the testing you will need to do for scripts in the F<script> (or F<bin> +as is also commonly used) paths of your Perl distribution. + +Further, it aims to provide this functionality with perfect +platform-compatibility, and in a way that is as unobtrusive as possible. + +That is, if the program works on a platform, then B<Test::Script> +should always work on that platform as well. Anything less than 100% is +considered unacceptable. + +In doing so, it is hoped that B<Test::Script> can become a module that +you can safely make a dependency of all your modules, without risking that +your module won't on some platform because of the dependency. + +Where a clash exists between wanting more functionality and maintaining +platform safety, this module will err on the side of platform safety. + +=head1 FUNCTIONS + +=cut + +use 5.005; +use strict; +use Carp (); +use Exporter (); +use File::Spec (); +use File::Spec::Unix (); +use Probe::Perl (); +use IPC::Run3 (); +use Test::Builder (); + +use vars qw{$VERSION @ISA @EXPORT}; +BEGIN { + $VERSION = '1.07'; + @ISA = 'Exporter'; + @EXPORT = qw{ + script_compiles + script_compiles_ok + script_runs + }; +} + +sub import { + my $self = shift; + my $pack = caller; + my $test = Test::Builder->new; + $test->exported_to($pack); + $test->plan(@_); + foreach ( @EXPORT ) { + $self->export_to_level(1, $self, $_); + } +} + +my $perl = undef; + +sub perl () { + $perl or + $perl = Probe::Perl->find_perl_interpreter; +} + +sub path ($) { + my $path = shift; + unless ( defined $path ) { + Carp::croak("Did not provide a script name"); + } + if ( File::Spec::Unix->file_name_is_absolute($path) ) { + Carp::croak("Script name must be relative"); + } + File::Spec->catfile( + File::Spec->curdir, + split /\//, $path + ); +} + + + + + +##################################################################### +# Test Functions + +=pod + +=head2 script_compiles + + script_compiles( 'script/foo.pl', 'Main script compiles' ); + +The C<script_compiles> test calls the script with "perl -c script.pl", +and checks that it returns without error. + +The path it should be passed is a relative unix-format script name. This +will be localised when running C<perl -c> and if the test fails the local +name used will be shown in the diagnostic output. + +Note also that the test will be run with the same L<perl> interpreter that +is running the test script (and not with the default system perl). This +will also be shown in the diagnostic output on failure. + +=cut + +sub script_compiles { + my $args = _script(shift); + my $unix = shift @$args; + my $path = path( $unix ); + my $cmd = [ perl, '-Mblib', '-c', $path, @$args ]; + my $stdin = ''; + my $stdout = ''; + my $stderr = ''; + my $rv = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr ); + my $exit = $? ? ($? >> 8) : 0; + my $ok = !! ( + $rv and $exit == 0 and $stderr =~ /syntax OK\s+\z/si + ); + + my $test = Test::Builder->new; + $test->ok( $ok, $_[0] || "Script $unix compiles" ); + $test->diag( "$exit - $stderr" ) unless $ok; + + return $ok; +} + +=pod + +=head2 script_runs + + script_runs( 'script/foo.pl', 'Main script runs' ); + +The C<script_runs> test executes the script with "perl script.pl" and checks +that it returns success. + +The path it should be passed is a relative unix-format script name. This +will be localised when running C<perl -c> and if the test fails the local +name used will be shown in the diagnostic output. + +The test will be run with the same L<perl> interpreter that is running the +test script (and not with the default system perl). This will also be shown +in the diagnostic output on failure. + +=cut + +sub script_runs { + my $args = _script(shift); + my $unix = shift @$args; + my $path = path( $unix ); + my $cmd = [ perl, '-Mblib', $path, @$args ]; + my $stdin = ''; + my $stdout = ''; + my $stderr = ''; + my $rv = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr ); + my $exit = $? ? ($? >> 8) : 0; + my $ok = !! ( $rv and $exit == 0 ); + + my $test = Test::Builder->new; + $test->ok( $ok, $_[0] || "Script $unix runs" ); + $test->diag( "$exit - $stderr" ) unless $ok; + + return $ok; +} + + + + + +###################################################################### +# Support Functions + +# Script params must be either a simple non-null string with the script +# name, or an array reference with one or more non-null strings. +sub _script { + my $in = shift; + if ( defined _STRING($in) ) { + return [ $in ]; + } + if ( _ARRAY($in) ) { + unless ( scalar grep { not defined _STRING($_) } @$in ) { + return $in; + } + } + Carp::croak("Invalid command parameter"); +} + +# Inline some basic Params::Util functions + +sub _ARRAY ($) { + (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; +} + +sub _STRING ($) { + (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef; +} + +BEGIN { + # Alias to old name + *script_compiles_ok = *script_compiles; +} + +1; + +=pod + +=head1 SUPPORT + +All bugs should be filed via the bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Script> + +For other issues, or commercial enhancement and support, contact the author. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<prove>, L<http://ali.as/> + +=head1 COPYRIGHT + +Copyright 2006 - 2009 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm b/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm new file mode 100755 index 00000000000..9c8716759a4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Simple.pm @@ -0,0 +1,214 @@ +package Test::Simple; + +use 5.006; + +use strict; + +our $VERSION = '0.94'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); + +my $CLASS = __PACKAGE__; + +=head1 NAME + +Test::Simple - Basic utilities for writing tests. + +=head1 SYNOPSIS + + use Test::Simple tests => 1; + + ok( $foo eq $bar, 'foo is bar' ); + + +=head1 DESCRIPTION + +** If you are unfamiliar with testing B<read Test::Tutorial> first! ** + +This is an extremely simple, extremely basic module for writing tests +suitable for CPAN modules and other pursuits. If you wish to do more +complicated testing, use the Test::More module (a drop-in replacement +for this one). + +The basic unit of Perl testing is the ok. For each thing you want to +test your program will print out an "ok" or "not ok" to indicate pass +or fail. You do this with the ok() function (see below). + +The only other constraint is you must pre-declare how many tests you +plan to run. This is in case something goes horribly wrong during the +test and your test program aborts, or skips a test or whatever. You +do this like so: + + use Test::Simple tests => 23; + +You must have a plan. + + +=over 4 + +=item B<ok> + + ok( $foo eq $bar, $name ); + ok( $foo eq $bar ); + +ok() is given an expression (in this case C<$foo eq $bar>). If it's +true, the test passed. If it's false, it didn't. That's about it. + +ok() prints out either "ok" or "not ok" along with a test number (it +keeps track of that for you). + + # This produces "ok 1 - Hell not yet frozen over" (or not ok) + ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); + +If you provide a $name, that will be printed along with the "ok/not +ok" to make it easier to find your test when if fails (just search for +the name). It also makes it easier for the next guy to understand +what your test is for. It's highly recommended you use test names. + +All tests are run in scalar context. So this: + + ok( @stuff, 'I have some stuff' ); + +will do what you mean (fail if stuff is empty) + +=cut + +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + return $CLASS->builder->ok(@_); +} + +=back + +Test::Simple will start by printing number of tests run in the form +"1..M" (so "1..5" means you're going to run 5 tests). This strange +format lets Test::Harness know how many tests you plan on running in +case something goes horribly wrong. + +If all your tests passed, Test::Simple will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Simple +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +This module is by no means trying to be a complete testing system. +It's just to get you started. Once you're off the ground its +recommended you look at L<Test::More>. + + +=head1 EXAMPLE + +Here's an example of a simple .t file for the fictional Film module. + + use Test::Simple tests => 5; + + use Film; # What you're testing. + + my $btaste = Film->new({ Title => 'Bad Taste', + Director => 'Peter Jackson', + Rating => 'R', + NumExplodingSheep => 1 + }); + ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' ); + + ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); + ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); + ok( $btaste->Rating eq 'R', 'Rating() get' ); + ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); + +It will produce output like this: + + 1..5 + ok 1 - new() works + ok 2 - Title() get + ok 3 - Director() get + not ok 4 - Rating() get + # Failed test 'Rating() get' + # in t/film.t at line 14. + ok 5 - NumExplodingSheep() get + # Looks like you failed 1 tests of 5 + +Indicating the Film::Rating() method is broken. + + +=head1 CAVEATS + +Test::Simple will only report a maximum of 254 failures in its exit +code. If this is a problem, you probably have a huge test script. +Split it into multiple files. (Otherwise blame the Unix folks for +using an unsigned short integer as the exit status). + +Because VMS's exit codes are much, much different than the rest of the +universe, and perl does horrible mangling to them that gets in my way, +it works like this on VMS. + + 0 SS$_NORMAL all tests successful + 4 SS$_ABORT something went wrong + +Unfortunately, I can't differentiate any further. + + +=head1 NOTES + +Test::Simple is B<explicitly> tested all the way back to perl 5.6.0. + +Test::Simple is thread-safe in perl 5.8.1 and up. + +=head1 HISTORY + +This module was conceived while talking with Tony Bowden in his +kitchen one night about the problems I was having writing some really +complicated feature into the new Testing module. He observed that the +main problem is not dealing with these edge cases but that people hate +to write tests B<at all>. What was needed was a dead simple module +that took all the hard work out of testing and was really, really easy +to learn. Paul Johnson simultaneously had this idea (unfortunately, +he wasn't in Tony's kitchen). This is it. + + +=head1 SEE ALSO + +=over 4 + +=item L<Test::More> + +More testing functions! Once you outgrow Test::Simple, look at +Test::More. Test::Simple is 100% forward compatible with Test::More +(i.e. you can just use Test::More instead of Test::Simple in your +programs and things will still work). + +=back + +Look in Test::More's SEE ALSO for more testing modules. + + +=head1 AUTHORS + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + + +=head1 COPYRIGHT + +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> + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm new file mode 100755 index 00000000000..fd0d7a399ae --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester.pm @@ -0,0 +1,645 @@ +use strict; + +package Test::Tester; + +BEGIN +{ + if (*Test::Builder::new{CODE}) + { + warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" + } +} + +use Test::Builder; +use Test::Tester::CaptureRunner; +use Test::Tester::Delegate; + +require Exporter; + +use vars qw( @ISA @EXPORT $VERSION ); + +$VERSION = "0.107"; +@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); +@ISA = qw( Exporter ); + +my $Test = Test::Builder->new; +my $Capture = Test::Tester::Capture->new; +my $Delegator = Test::Tester::Delegate->new; +$Delegator->{Object} = $Test; + +my $runner = Test::Tester::CaptureRunner->new; + +my $want_space = $ENV{TESTTESTERSPACE}; + +sub show_space +{ + $want_space = 1; +} + +my $colour = ''; +my $reset = ''; + +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{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"); + } + +} + +sub new_new +{ + return $Delegator; +} + +sub capture +{ + return Test::Tester::Capture->new; +} + +sub fh +{ + # experiment with capturing output, I don't like it + $runner = Test::Tester::FHRunner->new; + + return $Test; +} + +sub find_run_tests +{ + my $d = 1; + my $found = 0; + while ((not $found) and (my ($sub) = (caller($d))[3]) ) + { +# print "$d: $sub\n"; + $found = ($sub eq "Test::Tester::run_tests"); + $d++; + } + +# die "Didn't find 'run_tests' in caller stack" unless $found; + return $d; +} + +sub run_tests +{ + local($Delegator->{Object}) = $Capture; + + $runner->run_tests(@_); + + return ($runner->get_premature, $runner->get_results); +} + +sub check_test +{ + my $test = shift; + my $expect = shift; + my $name = shift; + $name = "" unless defined($name); + + @_ = ($test, [$expect], $name); + goto &check_tests; +} + +sub check_tests +{ + my $test = shift; + my $expects = shift; + my $name = shift; + $name = "" unless defined($name); + + my ($prem, @results) = eval { run_tests($test, $name) }; + + $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); + $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || + $Test->diag("Before any testing anything, your tests said\n$prem"); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_results(\@results, $expects, $name); + return ($prem, @results); +} + +sub cmp_field +{ + my ($result, $expect, $field, $desc) = @_; + + if (defined $expect->{$field}) + { + $Test->is_eq($result->{$field}, $expect->{$field}, + "$desc compare $field"); + } +} + +sub cmp_result +{ + my ($result, $expect, $name) = @_; + + my $sub_name = $result->{name}; + $sub_name = "" unless defined($name); + + my $desc = "subtest '$sub_name' of '$name'"; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + cmp_field($result, $expect, "ok", $desc); + + cmp_field($result, $expect, "actual_ok", $desc); + + cmp_field($result, $expect, "type", $desc); + + cmp_field($result, $expect, "reason", $desc); + + cmp_field($result, $expect, "name", $desc); + } + + # if we got no depth then default to 1 + my $depth = 1; + if (exists $expect->{depth}) + { + $depth = $expect->{depth}; + } + + # if depth was explicitly undef then don't test it + if (defined $depth) + { + $Test->is_eq($result->{depth}, $depth, "checking depth") || + $Test->diag('You need to change $Test::Builder::Level'); + } + + if (defined(my $exp = $expect->{diag})) + { + # if there actually is some diag then put a \n on the end if it's not + # there already + + $exp .= "\n" if (length($exp) and $exp !~ /\n$/); + if (not $Test->ok($result->{diag} eq $exp, + "subtest '$sub_name' of '$name' compare diag") + ) + { + 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); + } + + $Test->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) = @_; + + $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); + + for (my $i = 0; $i < @$expects; $i++) + { + my $expect = $expects->[$i]; + my $result = $results->[$i]; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_result($result, $expect, $name); + } +} + +######## nicked from Test::More +sub plan { + my(@plan) = @_; + + my $caller = caller; + + $Test->exported_to($caller); + + my @imports = (); + foreach my $idx (0..$#plan) { + if( $plan[$idx] eq 'import' ) { + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; + last; + } + } + + $Test->plan(@plan); + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + +sub import { + my($class) = shift; + { + no warnings 'redefine'; + *Test::Builder::new = \&new_new; + } + goto &plan; +} + +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + + +############ + +1; + +__END__ + +=head1 NAME + +Test::Tester - Ease testing test modules built with Test::Builder + +=head1 SYNOPSIS + + use Test::Tester tests => 6; + + use Test::MyStyle; + + check_test( + sub { + is_mystyle_eq("this", "that", "not eq"); + }, + { + ok => 0, # expect this to fail + name => "not eq", + diag => "Expected: 'this'\nGot: 'that'", + } + ); + +or + + use Test::Tester; + + 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 RESULTS + +The result of each test is captured in a hash. These hashes are the same as +the hashes returned by Test::Builder->details but with a couple of extra +fields. + +These fields are documented in L<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 + +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 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. + +=head1 AUTHOR + +This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts +are based on other people's work. + +Plan handling lifted from Test::More. written by Michael G Schwern +<schwern@pobox.com>. + +Test::Tester::Capture is a cut down and hacked up version of Test::Builder. +Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G +Schwern <schwern@pobox.com>. + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm new file mode 100755 index 00000000000..b1b4de69c75 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Capture.pm @@ -0,0 +1,223 @@ +use strict; + +package Test::Tester::Capture; + +use Test::Builder; + +use vars qw( @ISA ); +@ISA = qw( Test::Builder ); + +# Make Test::Tester::Capture thread-safe for ithreads. +BEGIN { + use Config; + if( $] >= 5.008 && $Config{useithreads} ) { + require threads; + require threads::shared; + threads::shared->import; + } + else { + *share = sub { 0 }; + *lock = sub { 0 }; + } +} + +my $Curr_Test = 0; share($Curr_Test); +my @Test_Results = (); share(@Test_Results); +my $Prem_Diag = {diag => ""}; share($Curr_Test); + +sub new +{ + # Test::Tester::Capgture::new used to just return __PACKAGE__ + # because Test::Builder::new enforced it's singleton nature by + # return __PACKAGE__. That has since changed, Test::Builder::new now + # returns a blessed has and around version 0.78, Test::Builder::todo + # started wanting to modify $self. To cope with this, we now return + # a blessed hash. This is a short-term hack, the correct thing to do + # is to detect which style of Test::Builder we're dealing with and + # act appropriately. + + my $class = shift; + return bless {}, $class; +} + +sub ok { + my($self, $test, $name) = @_; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + lock $Curr_Test; + $Curr_Test++; + + my($pack, $file, $line) = $self->caller; + + my $todo = $self->todo($pack); + + my $result = {}; + share($result); + + unless( $test ) { + @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if( $todo ) { + my $what_todo = $todo; + $result->{reason} = $what_todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $Test_Results[$Curr_Test-1] = $result; + + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $result->{fail_diag} = (" $msg test ($file at line $line)\n"); + } + + $result->{diag} = ""; + $result->{_level} = $Test::Builder::Level; + $result->{_depth} = Test::Tester::find_run_tests(); + + return $test ? 1 : 0; +} + +sub skip { + my($self, $why) = @_; + $why ||= ''; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + $Test_Results[$Curr_Test-1] = \%result; + + return 1; +} + +sub todo_skip { + my($self, $why) = @_; + $why ||= ''; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + + $Test_Results[$Curr_Test-1] = \%result; + + return 1; +} + +sub diag { + my($self, @msgs) = @_; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + # Escape each line with a #. + foreach (@msgs) { + $_ = 'undef' unless defined; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + + my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; + + $result->{diag} .= join("", @msgs); + + return 0; +} + +sub details { + return @Test_Results; +} + +sub premature +{ + return $Prem_Diag->{diag}; +} + +sub current_test +{ + if (@_ > 1) + { + die "Don't try to change the test number!"; + } + else + { + return $Curr_Test; + } +} + +sub reset +{ + $Curr_Test = 0; + @Test_Results = (); + $Prem_Diag = {diag => ""}; +} + +1; + +__END__ + +=head1 NAME + +Test::Tester::Capture - Help testing test modules built with Test::Builder + +=head1 DESCRIPTION + +This is a subclass of Test::Builder that overrides many of the methods so +that they don't output anything. It also keeps track of it's own set of test +results so that you can use Test::Builder based modules to perform tests on +other Test::Builder based modules. + +=head1 AUTHOR + +Most of the code here was lifted straight from Test::Builder and then had +chunks removed by Fergal Daly <fergal@esatclear.ie>. + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm new file mode 100755 index 00000000000..f14a4c145aa --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/CaptureRunner.pm @@ -0,0 +1,76 @@ +# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ +use strict; + +package Test::Tester::CaptureRunner; + +use Test::Tester::Capture; +require Exporter; + +sub new +{ + my $pkg = shift; + my $self = bless {}, $pkg; + return $self; +} + +sub run_tests +{ + my $self = shift; + + my $test = shift; + + capture()->reset; + + $self->{StartLevel} = $Test::Builder::Level; + &$test(); +} + +sub get_results +{ + my $self = shift; + my @results = capture()->details; + + my $start = $self->{StartLevel}; + foreach my $res (@results) + { + next if defined $res->{depth}; + my $depth = $res->{_depth} - $res->{_level} - $start - 3; +# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; + $res->{depth} = $depth; + } + + return @results; +} + +sub get_premature +{ + return capture()->premature; +} + +sub capture +{ + return Test::Tester::Capture->new; +} + +__END__ + +=head1 NAME + +Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder + +=head1 DESCRIPTION + +This stuff if needed to allow me to play with other ways of monitoring the +test results. + +=head1 AUTHOR + +Copyright 2003 by Fergal Daly <fergal@esatclear.ie>. + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm new file mode 100755 index 00000000000..7ddb921cdfc --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Tester/Delegate.pm @@ -0,0 +1,32 @@ +use strict; +use warnings; + +package Test::Tester::Delegate; + +use vars '$AUTOLOAD'; + +sub new +{ + my $pkg = shift; + + my $obj = shift; + my $self = bless {}, $pkg; + + return $self; +} + +sub AUTOLOAD +{ + my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; + + return if $sub eq "DESTROY"; + + my $obj = $_[0]->{Object}; + + my $ref = $obj->can($sub); + shift(@_); + unshift(@_, $obj); + goto &$ref; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod b/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod new file mode 100755 index 00000000000..46ac467ddae --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Tutorial.pod @@ -0,0 +1,604 @@ +=head1 NAME + +Test::Tutorial - A tutorial about writing really basic tests + +=head1 DESCRIPTION + + +I<AHHHHHHH!!!! NOT TESTING! Anything but testing! +Beat me, whip me, send me to Detroit, but don't make +me write tests!> + +I<*sob*> + +I<Besides, I don't know how to write the damned things.> + + +Is this you? Is writing tests right up there with writing +documentation and having your fingernails pulled out? Did you open up +a test and read + + ######## We start with some black magic + +and decide that's quite enough for you? + +It's ok. That's all gone now. We've done all the black magic for +you. And here are the tricks... + + +=head2 Nuts and bolts of testing. + +Here's the most basic test program. + + #!/usr/bin/perl -w + + print "1..1\n"; + + print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; + +since 1 + 1 is 2, it prints: + + 1..1 + ok 1 + +What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1> +"The first test passed". And that's about all magic there is to +testing. Your basic unit of testing is the I<ok>. For each thing you +test, an C<ok> is printed. Simple. B<Test::Harness> interprets your test +results to determine if you succeeded or failed (more on that later). + +Writing all these print statements rapidly gets tedious. Fortunately, +there's B<Test::Simple>. It has one function, C<ok()>. + + #!/usr/bin/perl -w + + use Test::Simple tests => 1; + + ok( 1 + 1 == 2 ); + +and that does the same thing as the code above. C<ok()> is the backbone +of Perl testing, and we'll be using it instead of roll-your-own from +here on. If C<ok()> gets a true value, the test passes. False, it +fails. + + #!/usr/bin/perl -w + + use Test::Simple tests => 2; + ok( 1 + 1 == 2 ); + ok( 2 + 2 == 5 ); + +from that comes + + 1..2 + ok 1 + not ok 2 + # Failed test (test.pl at line 5) + # Looks like you failed 1 tests of 2. + +C<1..2> "I'm going to run two tests." This number is used to ensure +your test program ran all the way through and didn't die or skip some +tests. C<ok 1> "The first test passed." C<not ok 2> "The second test +failed". Test::Simple helpfully prints out some extra commentary about +your tests. + +It's not scary. Come, hold my hand. We're going to give an example +of testing a module. For our example, we'll be testing a date +library, B<Date::ICal>. It's on CPAN, so download a copy and follow +along. [2] + + +=head2 Where to start? + +This is the hardest part of testing, where do you start? People often +get overwhelmed at the apparent enormity of the task of testing a +whole module. Best place to start is at the beginning. Date::ICal is +an object-oriented module, and that means you start by making an +object. So we test C<new()>. + + #!/usr/bin/perl -w + + use Test::Simple tests => 2; + + use Date::ICal; + + my $ical = Date::ICal->new; # create an object + ok( defined $ical ); # check that we got something + ok( $ical->isa('Date::ICal') ); # and it's the right class + +run that and you should get: + + 1..2 + ok 1 + ok 2 + +congratulations, you've written your first useful test. + + +=head2 Names + +That output isn't terribly descriptive, is it? When you have two +tests you can figure out which one is #2, but what if you have 102? + +Each test can be given a little descriptive name as the second +argument to C<ok()>. + + use Test::Simple tests => 2; + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + +So now you'd see... + + 1..2 + ok 1 - new() returned something + ok 2 - and it's the right class + + +=head2 Test the manual + +Simplest way to build up a decent testing suite is to just test what +the manual says it does. [3] Let's pull something out of the +L<Date::ICal/SYNOPSIS> and test that all its bits work. + + #!/usr/bin/perl -w + + use Test::Simple tests => 8; + + use Date::ICal; + + $ical = Date::ICal->new( year => 1964, month => 10, day => 16, + hour => 16, min => 12, sec => 47, + tz => '0530' ); + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + ok( $ical->sec == 47, ' sec()' ); + ok( $ical->min == 12, ' min()' ); + ok( $ical->hour == 16, ' hour()' ); + ok( $ical->day == 17, ' day()' ); + ok( $ical->month == 10, ' month()' ); + ok( $ical->year == 1964, ' year()' ); + +run that and you get: + + 1..8 + ok 1 - new() returned something + ok 2 - and it's the right class + ok 3 - sec() + ok 4 - min() + ok 5 - hour() + not ok 6 - day() + # Failed test (- at line 16) + ok 7 - month() + ok 8 - year() + # Looks like you failed 1 tests of 8. + +Whoops, a failure! [4] Test::Simple helpfully lets us know on what line +the failure occurred, but not much else. We were supposed to get 17, +but we didn't. What did we get?? Dunno. We'll have to re-run the +test in the debugger or throw in some print statements to find out. + +Instead, we'll switch from B<Test::Simple> to B<Test::More>. B<Test::More> +does everything B<Test::Simple> does, and more! In fact, Test::More does +things I<exactly> the way Test::Simple does. You can literally swap +Test::Simple out and put Test::More in its place. That's just what +we're going to do. + +Test::More does more than Test::Simple. The most important difference +at this point is it provides more informative ways to say "ok". +Although you can write almost any test with a generic C<ok()>, it +can't tell you what went wrong. Instead, we'll use the C<is()> +function, which lets us declare that something is supposed to be the +same as something else: + + #!/usr/bin/perl -w + + use Test::More tests => 8; + + use Date::ICal; + + $ical = Date::ICal->new( year => 1964, month => 10, day => 16, + hour => 16, min => 12, sec => 47, + tz => '0530' ); + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + is( $ical->sec, 47, ' sec()' ); + is( $ical->min, 12, ' min()' ); + is( $ical->hour, 16, ' hour()' ); + is( $ical->day, 17, ' day()' ); + is( $ical->month, 10, ' month()' ); + is( $ical->year, 1964, ' year()' ); + +"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place, +you get some more information + + 1..8 + ok 1 - new() returned something + ok 2 - and it's the right class + ok 3 - sec() + ok 4 - min() + ok 5 - hour() + not ok 6 - day() + # Failed test (- at line 16) + # got: '16' + # expected: '17' + ok 7 - month() + ok 8 - year() + # Looks like you failed 1 tests of 8. + +letting us know that C<$ical-E<gt>day> returned 16, but we expected 17. A +quick check shows that the code is working fine, we made a mistake +when writing up the tests. Just change it to: + + is( $ical->day, 16, ' day()' ); + +and everything works. + +So any time you're doing a "this equals that" sort of test, use C<is()>. +It even works on arrays. The test is always in scalar context, so you +can test how many elements are in a list this way. [5] + + is( @foo, 5, 'foo has 5 elements' ); + + +=head2 Sometimes the tests are wrong + +Which brings us to a very important lesson. Code has bugs. Tests are +code. Ergo, tests have bugs. A failing test could mean a bug in the +code, but don't discount the possibility that the test is wrong. + +On the flip side, don't be tempted to prematurely declare a test +incorrect just because you're having trouble finding the bug. +Invalidating a test isn't something to be taken lightly, and don't use +it as a cop out to avoid work. + + +=head2 Testing lots of values + +We're going to be wanting to test a lot of dates here, trying to trick +the code with lots of different edge cases. Does it work before 1970? +After 2038? Before 1904? Do years after 10,000 give it trouble? +Does it get leap years right? We could keep repeating the code above, +or we could set up a little try/expect loop. + + use Test::More tests => 32; + use Date::ICal; + + my %ICal_Dates = ( + # An ICal string And the year, month, day + # hour, minute and second we expect. + '19971024T120000' => # from the docs. + [ 1997, 10, 24, 12, 0, 0 ], + '20390123T232832' => # after the Unix epoch + [ 2039, 1, 23, 23, 28, 32 ], + '19671225T000000' => # before the Unix epoch + [ 1967, 12, 25, 0, 0, 0 ], + '18990505T232323' => # before the MacOS epoch + [ 1899, 5, 5, 23, 23, 23 ], + ); + + + while( my($ical_str, $expect) = each %ICal_Dates ) { + my $ical = Date::ICal->new( ical => $ical_str ); + + ok( defined $ical, "new(ical => '$ical_str')" ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + + is( $ical->year, $expect->[0], ' year()' ); + is( $ical->month, $expect->[1], ' month()' ); + is( $ical->day, $expect->[2], ' day()' ); + is( $ical->hour, $expect->[3], ' hour()' ); + is( $ical->min, $expect->[4], ' min()' ); + is( $ical->sec, $expect->[5], ' sec()' ); + } + +So now we can test bunches of dates by just adding them to +C<%ICal_Dates>. Now that it's less work to test with more dates, you'll +be inclined to just throw more in as you think of them. +Only problem is, every time we add to that we have to keep adjusting +the C<use Test::More tests =E<gt> ##> line. That can rapidly get +annoying. There's two ways to make this work better. + +First, we can calculate the plan dynamically using the C<plan()> +function. + + use Test::More; + use Date::ICal; + + my %ICal_Dates = ( + ...same as before... + ); + + # For each key in the hash we're running 8 tests. + plan tests => keys(%ICal_Dates) * 8; + + ...and then your tests... + +Or to be even more flexible, we use C<no_plan>. This means we're just +running some tests, don't know how many. [6] + + use Test::More 'no_plan'; # instead of tests => 32 + +now we can just add tests and not have to do all sorts of math to +figure out how many we're running. + + +=head2 Informative names + +Take a look at this line here + + ok( defined $ical, "new(ical => '$ical_str')" ); + +we've added more detail about what we're testing and the ICal string +itself we're trying out to the name. So you get results like: + + ok 25 - new(ical => '19971024T120000') + ok 26 - and it's the right class + ok 27 - year() + ok 28 - month() + ok 29 - day() + ok 30 - hour() + ok 31 - min() + ok 32 - sec() + +if something in there fails, you'll know which one it was and that +will make tracking down the problem easier. So try to put a bit of +debugging information into the test names. + +Describe what the tests test, to make debugging a failed test easier +for you or for the next person who runs your test. + + +=head2 Skipping tests + +Poking around in the existing Date::ICal tests, I found this in +F<t/01sanity.t> [7] + + #!/usr/bin/perl -w + + use Test::More tests => 7; + use Date::ICal; + + # Make sure epoch time is being handled sanely. + my $t1 = Date::ICal->new( epoch => 0 ); + is( $t1->epoch, 0, "Epoch time of 0" ); + + # XXX This will only work on unix systems. + is( $t1->ical, '19700101Z', " epoch to ical" ); + + is( $t1->year, 1970, " year()" ); + is( $t1->month, 1, " month()" ); + is( $t1->day, 1, " day()" ); + + # like the tests above, but starting with ical instead of epoch + my $t2 = Date::ICal->new( ical => '19700101Z' ); + is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); + + is( $t2->epoch, 0, " and back to ICal" ); + +The beginning of the epoch is different on most non-Unix operating +systems [8]. Even though Perl smooths out the differences for the +most part, certain ports do it differently. MacPerl is one off the +top of my head. [9] So rather than just putting a comment in the test, +we can explicitly say it's never going to work and skip the test. + + use Test::More tests => 7; + use Date::ICal; + + # Make sure epoch time is being handled sanely. + my $t1 = Date::ICal->new( epoch => 0 ); + is( $t1->epoch, 0, "Epoch time of 0" ); + + SKIP: { + skip('epoch to ICal not working on MacOS', 6) + if $^O eq 'MacOS'; + + is( $t1->ical, '19700101Z', " epoch to ical" ); + + is( $t1->year, 1970, " year()" ); + is( $t1->month, 1, " month()" ); + is( $t1->day, 1, " day()" ); + + # like the tests above, but starting with ical instead of epoch + my $t2 = Date::ICal->new( ical => '19700101Z' ); + is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); + + is( $t2->epoch, 0, " and back to ICal" ); + } + +A little bit of magic happens here. When running on anything but +MacOS, all the tests run normally. But when on MacOS, C<skip()> causes +the entire contents of the SKIP block to be jumped over. It's never +run. Instead, it prints special output that tells Test::Harness that +the tests have been skipped. + + 1..7 + ok 1 - Epoch time of 0 + ok 2 # skip epoch to ICal not working on MacOS + ok 3 # skip epoch to ICal not working on MacOS + ok 4 # skip epoch to ICal not working on MacOS + ok 5 # skip epoch to ICal not working on MacOS + ok 6 # skip epoch to ICal not working on MacOS + ok 7 # skip epoch to ICal not working on MacOS + +This means your tests won't fail on MacOS. This means less emails +from MacPerl users telling you about failing tests that you know will +never work. You've got to be careful with skip tests. These are for +tests which don't work and I<never will>. It is not for skipping +genuine bugs (we'll get to that in a moment). + +The tests are wholly and completely skipped. [10] This will work. + + SKIP: { + skip("I don't wanna die!"); + + die, die, die, die, die; + } + + +=head2 Todo tests + +Thumbing through the Date::ICal man page, I came across this: + + ical + + $ical_string = $ical->ical; + + Retrieves, or sets, the date on the object, using any + valid ICal date/time string. + +"Retrieves or sets". Hmmm, didn't see a test for using C<ical()> to set +the date in the Date::ICal test suite. So I'll write one. + + use Test::More tests => 1; + use Date::ICal; + + my $ical = Date::ICal->new; + $ical->ical('20201231Z'); + is( $ical->ical, '20201231Z', 'Setting via ical()' ); + +run that and I get + + 1..1 + not ok 1 - Setting via ical() + # Failed test (- at line 6) + # got: '20010814T233649Z' + # expected: '20201231Z' + # Looks like you failed 1 tests of 1. + +Whoops! Looks like it's unimplemented. Let's assume we don't have +the time to fix this. [11] Normally, you'd just comment out the test +and put a note in a todo list somewhere. Instead, we're going to +explicitly state "this test will fail" by wrapping it in a C<TODO> block. + + use Test::More tests => 1; + + TODO: { + local $TODO = 'ical($ical) not yet implemented'; + + my $ical = Date::ICal->new; + $ical->ical('20201231Z'); + + is( $ical->ical, '20201231Z', 'Setting via ical()' ); + } + +Now when you run, it's a little different: + + 1..1 + not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented + # got: '20010822T201551Z' + # expected: '20201231Z' + +Test::More doesn't say "Looks like you failed 1 tests of 1". That '# +TODO' tells Test::Harness "this is supposed to fail" and it treats a +failure as a successful test. So you can write tests even before +you've fixed the underlying code. + +If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY +SUCCEEDED". When that happens, you simply remove the TODO block with +C<local $TODO> and turn it into a real test. + + +=head2 Testing with taint mode. + +Taint mode is a funny thing. It's the globalest of all global +features. Once you turn it on, it affects I<all> code in your program +and I<all> modules used (and all the modules they use). If a single +piece of code isn't taint clean, the whole thing explodes. With that +in mind, it's very important to ensure your module works under taint +mode. + +It's very simple to have your tests run under taint mode. Just throw +a C<-T> into the C<#!> line. Test::Harness will read the switches +in C<#!> and use them to run your tests. + + #!/usr/bin/perl -Tw + + ...test normally here... + +So when you say C<make test> it will be run with taint mode and +warnings on. + + +=head1 FOOTNOTES + +=over 4 + +=item 1 + +The first number doesn't really mean anything, but it has to be 1. +It's the second number that's important. + +=item 2 + +For those following along at home, I'm using version 1.31. It has +some bugs, which is good -- we'll uncover them with our tests. + +=item 3 + +You can actually take this one step further and test the manual +itself. Have a look at B<Test::Inline> (formerly B<Pod::Tests>). + +=item 4 + +Yes, there's a mistake in the test suite. What! Me, contrived? + +=item 5 + +We'll get to testing the contents of lists later. + +=item 6 + +But what happens if your test program dies halfway through?! Since we +didn't say how many tests we're going to run, how can we know it +failed? No problem, Test::More employs some magic to catch that death +and turn the test into a failure, even if every test passed up to that +point. + +=item 7 + +I cleaned it up a little. + +=item 8 + +Most Operating Systems record time as the number of seconds since a +certain date. This date is the beginning of the epoch. Unix's starts +at midnight January 1st, 1970 GMT. + +=item 9 + +MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, +November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a +problem. + +=item 10 + +As long as the code inside the SKIP block at least compiles. Please +don't ask how. No, it's not a filter. + +=item 11 + +Do NOT be tempted to use TODO tests as a way to avoid fixing simple +bugs! + +=back + +=head1 AUTHORS + +Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers! + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This documentation is free; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Irrespective of its distribution, all code examples in these files +are hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun +or for profit as you see fit. A simple comment in the code giving +credit would be courteous but is not required. + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm b/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm new file mode 100755 index 00000000000..7776239fe6a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/Warn.pm @@ -0,0 +1,535 @@ +=head1 NAME + +Test::Warn - Perl extension to test methods for warnings + +=head1 SYNOPSIS + + use Test::Warn; + + warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning"; + warnings_are {bar(1,1)} ["Width very small", "Height very small"]; + + warning_is {add(2,2)} undef, "No warning to calc 2+2"; # or + warnings_are {add(2,2)} [], "No warning to calc 2+2"; # what reads better :-) + + warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test"; + warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i]; + + warning_is {foo()} {carped => "didn't found the right parameters"}; + warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}]; + + warning_like {foo(undef)} 'uninitialized'; + warning_like {bar(file => '/etc/passwd')} 'io'; + + warning_like {eval q/"$x"; $x;/} + [qw/void uninitialized/], + "some warnings at compile time"; + + warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; + +=head1 DESCRIPTION + +A good style of Perl programming calls for a lot of diverse regression tests. + +This module provides a few convenience methods for testing warning based code. + +If you are not already familiar with the Test::More manpage +now would be the time to go take a look. + +=head2 FUNCTIONS + +=over 4 + +=item warning_is BLOCK STRING, TEST_NAME + +Tests that BLOCK gives exactly the one specificated warning. +The test fails if the BLOCK warns more then one times or doesn't warn. +If the string is undef, +then the tests succeeds if the BLOCK doesn't give any warning. +Another way to say that there aren't any warnings in the block, +is C<warnings_are {foo()} [], "no warnings in">. + +If you want to test for a warning given by carp, +You have to write something like: +C<warning_is {carp "msg"} {carped =E<gt> 'msg'}, "Test for a carped warning">. +The test will fail, +if a "normal" warning is found instead of a "carped" one. + +Note: C<warn "foo"> would print something like C<foo at -e line 1>. +This method ignores everything after the at. That means, to match this warning +you would have to call C<warning_is {warn "foo"} "foo", "Foo succeeded">. +If you need to test for a warning at an exactly line, +try better something like C<warning_like {warn "foo"} qr/at XYZ.dat line 5/>. + +warning_is and warning_are are only aliases to the same method. +So you also could write +C<warning_is {foo()} [], "no warning"> or something similar. +I decided to give two methods to have some better readable method names. + +A true value is returned if the test succeeds, false otherwise. + +The test name is optional, but recommended. + + +=item warnings_are BLOCK ARRAYREF, TEST_NAME + +Tests to see that BLOCK gives exactly the specificated warnings. +The test fails if the BLOCK warns a different number than the size of the ARRAYREf +would have expected. +If the ARRAYREF is equal to [], +then the test succeeds if the BLOCK doesn't give any warning. + +Please read also the notes to warning_is as these methods are only aliases. + +If you want more than one tests for carped warnings look that way: +C<warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];> or +C<warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]>. +Note that C<{carped => ...}> has always to be a hash ref. + +=item warning_like BLOCK REGEXP, TEST_NAME + +Tests that BLOCK gives exactly one warning and it can be matched to the given regexp. +If the string is undef, +then the tests succeeds iff the BLOCK doesn't give any warning. + +The REGEXP is matched after the whole warn line, +which consists in general of "WARNING at __FILE__ line __LINE__". +So you can check for a warning in at File Foo.pm line 5 with +C<warning_like {bar()} qr/at Foo.pm line 5/, "Testname">. +I don't know whether it's sensful to do such a test :-( +However, you should be prepared as a matching with 'at', 'file', '\d' +or similar will always pass. +Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl. + +You can also write the regexp in a string as "/.../" +instead of using the qr/.../ syntax. +Note that the slashes are important in the string, +as strings without slashes are reserved for warning categories +(to match warning categories as can be seen in the perllexwarn man page). + +Similar to C<warning_is>, +you can test for warnings via C<carp> with: +C<warning_like {bar()} {carped => qr/bar called too early/i};> + +Similar to C<warning_is>/C<warnings_are>, +C<warning_like> and C<warnings_like> are only aliases to the same methods. + +A true value is returned if the test succeeds, false otherwise. + +The test name is optional, but recommended. + +=item warning_like BLOCK STRING, TEST_NAME + +Tests whether a BLOCK gives exactly one warning of the passed category. +The categories are grouped in a tree, +like it is expressed in perllexwarn. +Note, that they have the hierarchical structure from perl 5.8.0, +wich has a little bit changed to 5.6.1 or earlier versions +(You can access the internal used tree with C<$Test::Warn::Categorization::tree>, +although I wouldn't recommend it) + +Thanks to the grouping in a tree, +it's simple possible to test for an 'io' warning, +instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning. + +Note, that warnings occuring at compile time, +can only be catched in an eval block. So + + warning_like {eval q/"$x"; $x;/} + [qw/void uninitialized/], + "some warnings at compile time"; + +will work, +while it wouldn't work without the eval. + +Note, that it isn't possible yet, +to test for own categories, +created with warnings::register. + +=item warnings_like BLOCK ARRAYREF, TEST_NAME + +Tests to see that BLOCK gives exactly the number of the specificated warnings +and all the warnings have to match in the defined order to the +passed regexes. + +Please read also the notes to warning_like as these methods are only aliases. + +Similar to C<warnings_are>, +you can test for multiple warnings via C<carp> +and for warning categories, too: + + warnings_like {foo()} + [qr/bar warning/, + qr/bar warning/, + {carped => qr/bar warning/i}, + 'io' + ], + "I hope, you'll never have to write a test for so many warnings :-)"; + +=item warnings_exist BLOCK STRING|ARRAYREF, TEST_NAME + +Same as warning_like, but will warn() all warnings that do not match the supplied regex/category, +instead of registering an error. Use this test when you just want to make sure that specific +warnings were generated, and couldn't care less if other warnings happened in the same block +of code. + + warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; + + warnings_exist {...} ['uninitialized'], "Expected warning is thrown"; + +=back + +=head2 EXPORT + +C<warning_is>, +C<warnings_are>, +C<warning_like>, +C<warnings_like>, +C<warnings_exist> by default. + +=head1 BUGS + +Please note that warnings with newlines inside are making a lot of trouble. +The only sensible way to handle them is to use are the C<warning_like> or +C<warnings_like> methods. Background for these problems is that there is no +really secure way to distinguish between warnings with newlines and a tracing +stacktrace. + +If a method has it's own warn handler, +overwriting C<$SIG{__WARN__}>, +my test warning methods won't get these warnings. + +The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't extremely tested. +Please use this calling style with higher attention and +tell me if you find a bug. + +=head1 TODO + +Improve this documentation. + +The code has some parts doubled - especially in the test scripts. +This is really awkward and has to be changed. + +Please feel free to suggest me any improvements. + +=head1 SEE ALSO + +Have a look to the similar L<Test::Exception> module. Test::Trap + +=head1 THANKS + +Many thanks to Adrian Howard, chromatic and Michael G. Schwern, +who have given me a lot of ideas. + +=head1 AUTHOR + +Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2002 by Janek Schleicher + +Copyright 2007-2009 by Alexandr Ciornii, L<http://chorny.net/> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + + +package Test::Warn; + +use 5.006; +use strict; +use warnings; + +#use Array::Compare; +use Sub::Uplevel 0.12; + +our $VERSION = '0.21'; + +require Exporter; + +our @ISA = qw(Exporter); + +our %EXPORT_TAGS = ( 'all' => [ qw( + @EXPORT +) ] ); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw( + warning_is warnings_are + warning_like warnings_like + warnings_exist +); + +use Test::Builder; +my $Tester = Test::Builder->new; + +{ +no warnings 'once'; +*warning_is = *warnings_are; +*warning_like = *warnings_like; +} + +sub warnings_are (&$;$) { + my $block = shift; + my @exp_warning = map {_canonical_exp_warning($_)} + _to_array_if_necessary( shift() || [] ); + my $testname = shift; + my @got_warning = (); + local $SIG{__WARN__} = sub { + my ($called_from) = caller(0); # to find out Carping methods + push @got_warning, _canonical_got_warning($called_from, shift()); + }; + uplevel 1,$block; + my $ok = _cmp_is( \@got_warning, \@exp_warning ); + $Tester->ok( $ok, $testname ); + $ok or _diag_found_warning(@got_warning), + _diag_exp_warning(@exp_warning); + return $ok; +} + + +sub warnings_like (&$;$) { + my $block = shift; + my @exp_warning = map {_canonical_exp_warning($_)} + _to_array_if_necessary( shift() || [] ); + my $testname = shift; + my @got_warning = (); + local $SIG{__WARN__} = sub { + my ($called_from) = caller(0); # to find out Carping methods + push @got_warning, _canonical_got_warning($called_from, shift()); + }; + uplevel 1,$block; + my $ok = _cmp_like( \@got_warning, \@exp_warning ); + $Tester->ok( $ok, $testname ); + $ok or _diag_found_warning(@got_warning), + _diag_exp_warning(@exp_warning); + return $ok; +} + +sub warnings_exist (&$;$) { + my $block = shift; + my @exp_warning = map {_canonical_exp_warning($_)} + _to_array_if_necessary( shift() || [] ); + my $testname = shift; + my @got_warning = (); + local $SIG{__WARN__} = sub { + my ($called_from) = caller(0); # to find out Carping methods + my $wrn_text=shift; + my $wrn_rec=_canonical_got_warning($called_from, $wrn_text); + foreach my $wrn (@exp_warning) { + if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) { + push @got_warning, $wrn_rec; + return; + } + } + warn $wrn_text; + }; + uplevel 1,$block; + my $ok = _cmp_like( \@got_warning, \@exp_warning ); + $Tester->ok( $ok, $testname ); + $ok or _diag_found_warning(@got_warning), + _diag_exp_warning(@exp_warning); + return $ok; +} + + +sub _to_array_if_necessary { + return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]); +} + +sub _canonical_got_warning { + my ($called_from, $msg) = @_; + my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn'; + my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included + return {$warn_kind => $warning_stack[0]}; # return only the real message +} + +sub _canonical_exp_warning { + my ($exp) = @_; + if (ref($exp) eq 'HASH') { # could be {carped => ...} + my $to_carp = $exp->{carped} or return; # undefined message are ignored + return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] } + ? map({ {carped => $_} } grep {defined $_} @$to_carp) + : +{carped => $to_carp}; + } + return {warn => $exp}; +} + +sub _cmp_got_to_exp_warning { + my ($got_kind, $got_msg) = %{ shift() }; + my ($exp_kind, $exp_msg) = %{ shift() }; + return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); + my $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/; + return $cmp; +} + +sub _cmp_got_to_exp_warning_like { + my ($got_kind, $got_msg) = %{ shift() }; + my ($exp_kind, $exp_msg) = %{ shift() }; + return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); + if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//' + my $cmp = $got_msg =~ /$re/; + return $cmp; + } else { + return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg); + } +} + + +sub _cmp_is { + my @got = @{ shift() }; + my @exp = @{ shift() }; + scalar @got == scalar @exp or return 0; + my $cmp = 1; + $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got); + return $cmp; +} + +sub _cmp_like { + my @got = @{ shift() }; + my @exp = @{ shift() }; + scalar @got == scalar @exp or return 0; + my $cmp = 1; + $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got); + return $cmp; +} + +sub _diag_found_warning { + foreach (@_) { + if (ref($_) eq 'HASH') { + ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}") + : $Tester->diag("found warning: ${$_}{warn}"); + } else { + $Tester->diag( "found warning: $_" ); + } + } + $Tester->diag( "didn't found a warning" ) unless @_; +} + +sub _diag_exp_warning { + foreach (@_) { + if (ref($_) eq 'HASH') { + ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}") + : $Tester->diag("expected to find warning: ${$_}{warn}"); + } else { + $Tester->diag( "expected to find warning: $_" ); + } + } + $Tester->diag( "didn't expect to find a warning" ) unless @_; +} + +package Test::Warn::DAG_Node_Tree; + +use strict; +use warnings; +use base 'Tree::DAG_Node'; + + +sub nice_lol_to_tree { + my $class = shift; + $class->new( + { + name => shift(), + daughters => [_nice_lol_to_daughters(shift())] + }); +} + +sub _nice_lol_to_daughters { + my @names = @{ shift() }; + my @daughters = (); + my $last_daughter = undef; + foreach (@names) { + if (ref($_) ne 'ARRAY') { + $last_daughter = Tree::DAG_Node->new({name => $_}); + push @daughters, $last_daughter; + } else { + $last_daughter->add_daughters(_nice_lol_to_daughters($_)); + } + } + return @daughters; +} + +sub depthsearch { + my ($self, $search_name) = @_; + my $found_node = undef; + $self->walk_down({callback => sub { + my $node = shift(); + $node->name eq $search_name and $found_node = $node,!"go on"; + "go on with searching"; + }}); + return $found_node; +} + +package Test::Warn::Categorization; + +use Carp; + +our $tree = Test::Warn::DAG_Node_Tree->nice_lol_to_tree( + all => [ 'closure', + 'deprecated', + 'exiting', + 'glob', + 'io' => [ 'closed', + 'exec', + 'layer', + 'newline', + 'pipe', + 'unopened' + ], + 'misc', + 'numeric', + 'once', + 'overflow', + 'pack', + 'portable', + 'recursion', + 'redefine', + 'regexp', + 'severe' => [ 'debugging', + 'inplace', + 'internal', + 'malloc' + ], + 'signal', + 'substr', + 'syntax' => [ 'ambiguous', + 'bareword', + 'digit', + 'parenthesis', + 'precedence', + 'printf', + 'prototype', + 'qw', + 'reserved', + 'semicolon' + ], + 'taint', + 'threads', + 'uninitialized', + 'unpack', + 'untie', + 'utf8', + 'void', + 'y2k' + ] +); + +sub _warning_category_regexp { + my $sub_tree = $tree->depthsearch(shift()) or return; + my $re = join "|", map {$_->name} $sub_tree->leaves_under; + return qr/(?=\w)$re/; +} + +sub warning_like_category { + my ($warning, $category) = @_; + my $re = _warning_category_regexp($category) or + carp("Unknown warning category '$category'"),return; + my $ok = $warning =~ /$re/; + return $ok; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm b/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm new file mode 100755 index 00000000000..a3d5c8d7318 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Test/YAML.pm @@ -0,0 +1,270 @@ +package Test::YAML; + +use Test::Base 0.47 -Base; +use lib 'lib'; + +our $VERSION = '0.71'; +our $YAML = 'YAML'; +our @EXPORT = qw( + no_diff + run_yaml_tests + run_roundtrip_nyn roundtrip_nyn + run_load_passes load_passes + dumper Load Dump LoadFile DumpFile + XXX +); + +delimiters('===', '+++'); + +sub Dump () { YAML(Dump => @_) } +sub Load () { YAML(Load => @_) } +sub DumpFile () { YAML(DumpFile => @_) } +sub LoadFile () { YAML(LoadFile => @_) } + +sub YAML () { + load_yaml_pm(); + my $meth = shift; + my $code = $YAML->can($meth) or die "$YAML cannot do $meth"; + goto &$code; +} + +sub load_yaml_pm { + my $file = "$YAML.pm"; + $file =~ s{::}{/}g; + require $file; +} + +sub run_yaml_tests() { + run { + my $block = shift; + &{_get_function($block)}($block) unless + _skip_tests_for_now($block) or + _skip_yaml_tests($block); + }; +} + +sub run_roundtrip_nyn() { + my @options = @_; + run { + my $block = shift; + roundtrip_nyn($block, @options); + }; +} + +sub roundtrip_nyn() { + my $block = shift; + my $option = shift || ''; + die "'perl' data section required" + unless exists $block->{perl}; + my @values = eval $block->perl; + die "roundtrip_nyn eval perl error: $@" if $@; + my $config = $block->config || ''; + my $result = eval "$config; Dump(\@values)"; + die "roundtrip_nyn YAML::Dump error: $@" if $@; + if (exists $block->{yaml}) { + is $result, $block->yaml, + $block->description . ' (n->y)'; + } + else { + pass $block->description . ' (n->y)'; + } + + return if exists $block->{no_round_trip} or + not exists $block->{yaml}; + + if ($option eq 'dumper') { + is dumper(Load($block->yaml)), dumper(@values), + $block->description . ' (y->n)'; + } + else { + is_deeply [Load($block->yaml)], [@values], + $block->description . ' (y->n)'; + } +} + +sub count_roundtrip_nyn() { + my $block = shift or die "Bad call to count_roundtrip_nyn"; + return 1 if exists $block->{skip_this_for_now}; + my $count = 0; + $count++ if exists $block->{perl}; + $count++ unless exists $block->{no_round_trip} or + not exists $block->{yaml}; + die "Invalid test definition" unless $count; + return $count; +} + +sub run_load_passes() { + run { + my $block = shift; + my $yaml = $block->yaml; + eval { YAML(Load => $yaml) }; + is("$@", ""); + }; +} + +sub load_passes() { + my $block = shift; + my $yaml = $block->yaml; + eval { YAML(Load => $yaml) }; + is "$@", "", $block->description; +} + +sub count_load_passes() {1} + +sub dumper() { + require Data::Dumper; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Indent = 1; + return Data::Dumper::Dumper(@_); +} + +{ + no warnings; + sub XXX { + YAML::Base::XXX(@_); + } +} + +sub _count_tests() { + my $block = shift or die "Bad call to _count_tests"; + no strict 'refs'; + &{'count_' . _get_function_name($block)}($block); +} + +sub _get_function_name() { + my $block = shift; + return $block->function || 'roundtrip_nyn'; +} + +sub _get_function() { + my $block = shift; + no strict 'refs'; + \ &{_get_function_name($block)}; +} + +sub _skip_tests_for_now() { + my $block = shift; + if (exists $block->{skip_this_for_now}) { + _skip_test( + $block->description, + _count_tests($block), + ); + return 1; + } + return 0; +} + +sub _skip_yaml_tests() { + my $block = shift; + if ($block->skip_unless_modules) { + my @modules = split /[\s\,]+/, $block->skip_unless_modules; + for my $module (@modules) { + eval "require $module"; + if ($@) { + _skip_test( + "This test requires the '$module' module", + _count_tests($block), + ); + return 1; + } + } + } + return 0; +} + +sub _skip_test() { + my ($message, $count) = @_; + SKIP: { + skip($message, $count); + } +} + +#------------------------------------------------------------------------------- +package Test::YAML::Filter; + +use Test::Base::Filter (); + +our @ISA = 'Test::Base::Filter'; + +sub yaml_dump { + Test::YAML::Dump(@_); +} + +sub yaml_load { + Test::YAML::Load(@_); +} + +sub Dump { goto &Test::YAML::Dump } +sub Load { goto &Test::YAML::Load } +sub DumpFile { goto &Test::YAML::DumpFile } +sub LoadFile { goto &Test::YAML::LoadFile } + +sub yaml_load_or_fail { + my ($result, $error, $warning) = + $self->_yaml_load_result_error_warning(@_); + return $error || $result; +} + +sub yaml_load_error_or_warning { + my ($result, $error, $warning) = + $self->_yaml_load_result_error_warning(@_); + return $error || $warning || ''; +} + +sub perl_eval_error_or_warning { + my ($result, $error, $warning) = + $self->_perl_eval_result_error_warning(@_); + return $error || $warning || ''; +} + +sub _yaml_load_result_error_warning { + $self->assert_scalar(@_); + my $yaml = shift; + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join '', @_ }; + my $result = eval { + $self->yaml_load($yaml); + }; + return ($result, $@, $warning); +} + +sub _perl_eval_result_error_warning { + $self->assert_scalar(@_); + my $perl = shift; + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join '', @_ }; + my $result = eval $perl; + return ($result, $@, $warning); +} + +1; + +=head1 NAME + +Test::YAML - Testing Module for YAML Implementations + +=head1 SYNOPSIS + + use Test::YAML tests => 1; + + pass; + +=head1 DESCRIPTION + +Test::YAML is a subclass of Test::Base with YAML specific support. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut |