From ccbd73a450bd33362373a3a066beffb348f528a7 Mon Sep 17 00:00:00 2001 From: Steve Peters Date: Wed, 15 Oct 2008 13:11:04 +0000 Subject: [PATCH] Upgrade to Test-Simple-0.82. p4raw-id: //depot/perl@34483 --- lib/Test/Builder.pm | 890 ++++++++++++++--------- lib/Test/Builder/Module.pm | 32 +- lib/Test/Builder/Tester.pm | 245 +++---- lib/Test/Builder/Tester/Color.pm | 4 +- lib/Test/More.pm | 416 ++++++----- lib/Test/Simple.pm | 39 +- lib/Test/Simple/t/00test_harness_check.t | 1 + lib/Test/Simple/t/BEGIN_require_ok.t | 1 + lib/Test/Simple/t/BEGIN_use_ok.t | 1 + lib/Test/Simple/t/{ => Builder}/Builder.t | 1 + lib/Test/Simple/t/{ => Builder}/carp.t | 1 + lib/Test/Simple/t/{ => Builder}/create.t | 1 + lib/Test/Simple/t/{ => Builder}/curr_test.t | 1 + lib/Test/Simple/t/{ => Builder}/details.t | 1 + lib/Test/Simple/t/{ => Builder}/has_plan.t | 1 + lib/Test/Simple/t/{ => Builder}/has_plan2.t | 1 + lib/Test/Simple/t/{ => Builder}/is_fh.t | 1 + lib/Test/Simple/t/{ => Builder}/maybe_regex.t | 1 + lib/Test/Simple/t/{ => Builder}/no_diag.t | 1 + lib/Test/Simple/t/{ => Builder}/no_ending.t | 1 + lib/Test/Simple/t/{ => Builder}/no_header.t | 1 + lib/Test/Simple/t/{ => Builder}/ok_obj.t | 1 + lib/Test/Simple/t/{ => Builder}/output.t | 1 + lib/Test/Simple/t/{ => Builder}/reset.t | 1 + lib/Test/Simple/t/{ => Builder}/try.t | 3 +- lib/Test/Simple/t/More.t | 1 + lib/Test/Simple/t/{ => Tester}/tbt_01basic.t | 5 +- lib/Test/Simple/t/{ => Tester}/tbt_02fhrestore.t | 1 + lib/Test/Simple/t/{ => Tester}/tbt_03die.t | 1 + lib/Test/Simple/t/Tester/tbt_04line_num.t | 9 + lib/Test/Simple/t/{ => Tester}/tbt_05faildiag.t | 1 + lib/Test/Simple/t/{ => Tester}/tbt_06errormess.t | 1 + lib/Test/Simple/t/{ => Tester}/tbt_07args.t | 1 + lib/Test/Simple/t/bad_plan.t | 1 + lib/Test/Simple/t/bail_out.t | 1 + lib/Test/Simple/t/buffer.t | 1 + lib/Test/Simple/t/circular_data.t | 1 + lib/Test/Simple/t/cmp_ok.t | 1 + lib/Test/Simple/t/diag.t | 1 + lib/Test/Simple/t/died.t | 46 ++ lib/Test/Simple/t/dont_overwrite_die_handler.t | 1 + lib/Test/Simple/t/eq_set.t | 1 + lib/Test/Simple/t/exit.t | 5 +- lib/Test/Simple/t/explain.t | 28 + lib/Test/Simple/t/extra.t | 3 +- lib/Test/Simple/t/extra_one.t | 3 +- lib/Test/Simple/t/fail-like.t | 40 +- lib/Test/Simple/t/fail-more.t | 92 ++- lib/Test/Simple/t/fail.t | 1 + lib/Test/Simple/t/fail_one.t | 1 + lib/Test/Simple/t/filehandles.t | 1 + lib/Test/Simple/t/fork.t | 1 + lib/Test/Simple/t/harness_active.t | 1 + lib/Test/Simple/t/import.t | 1 + lib/Test/Simple/t/is_deeply_dne_bug.t | 1 + lib/Test/Simple/t/is_deeply_fail.t | 1 + lib/Test/Simple/t/is_deeply_with_threads.t | 5 +- lib/Test/Simple/t/lib/Dummy.pm | 3 +- lib/Test/Simple/t/lib/MyOverload.pm | 14 +- lib/Test/Simple/t/lib/NoExporter.pm | 4 +- lib/Test/Simple/t/missing.t | 9 +- lib/Test/Simple/t/new_ok.t | 42 ++ lib/Test/Simple/t/no_plan.t | 17 +- lib/Test/Simple/t/no_tests.t | 45 ++ lib/Test/Simple/t/note.t | 36 + lib/Test/Simple/t/overload.t | 1 + lib/Test/Simple/t/overload_threads.t | 1 + lib/Test/Simple/t/plan.t | 1 + lib/Test/Simple/t/plan_bad.t | 6 +- lib/Test/Simple/t/plan_is_noplan.t | 1 + lib/Test/Simple/t/plan_no_plan.t | 1 + lib/Test/Simple/t/plan_shouldnt_import.t | 1 + lib/Test/Simple/t/plan_skip_all.t | 1 + lib/Test/Simple/t/require_ok.t | 1 + lib/Test/Simple/t/simple.t | 1 + lib/Test/Simple/t/skip.t | 1 + lib/Test/Simple/t/skipall.t | 1 + lib/Test/Simple/t/tbm_doesnt_set_exported_to.t | 3 +- lib/Test/Simple/t/tbt_04line_num.t | 8 - lib/Test/Simple/t/thread_taint.t | 3 +- lib/Test/Simple/t/threads.t | 1 + lib/Test/Simple/t/todo.t | 80 +- lib/Test/Simple/t/undef.t | 6 +- lib/Test/Simple/t/use_ok.t | 10 +- lib/Test/Simple/t/useing.t | 1 + lib/Test/Simple/t/utf8.t | 1 + lib/Test/Tutorial.pod | 1 + 87 files changed, 1440 insertions(+), 766 deletions(-) rename lib/Test/Simple/t/{ => Builder}/Builder.t (86%) rename lib/Test/Simple/t/{ => Builder}/carp.t (85%) rename lib/Test/Simple/t/{ => Builder}/create.t (89%) rename lib/Test/Simple/t/{ => Builder}/curr_test.t (71%) rename lib/Test/Simple/t/{ => Builder}/details.t (96%) rename lib/Test/Simple/t/{ => Builder}/has_plan.t (78%) rename lib/Test/Simple/t/{ => Builder}/has_plan2.t (77%) rename lib/Test/Simple/t/{ => Builder}/is_fh.t (90%) rename lib/Test/Simple/t/{ => Builder}/maybe_regex.t (92%) rename lib/Test/Simple/t/{ => Builder}/no_diag.t (59%) rename lib/Test/Simple/t/{ => Builder}/no_ending.t (76%) rename lib/Test/Simple/t/{ => Builder}/no_header.t (74%) rename lib/Test/Simple/t/{ => Builder}/ok_obj.t (82%) rename lib/Test/Simple/t/{ => Builder}/output.t (94%) rename lib/Test/Simple/t/{ => Builder}/reset.t (95%) rename lib/Test/Simple/t/{ => Builder}/try.t (82%) rename lib/Test/Simple/t/{ => Tester}/tbt_01basic.t (84%) rename lib/Test/Simple/t/{ => Tester}/tbt_02fhrestore.t (91%) rename lib/Test/Simple/t/{ => Tester}/tbt_03die.t (68%) create mode 100644 lib/Test/Simple/t/Tester/tbt_04line_num.t rename lib/Test/Simple/t/{ => Tester}/tbt_05faildiag.t (88%) rename lib/Test/Simple/t/{ => Tester}/tbt_06errormess.t (96%) rename lib/Test/Simple/t/{ => Tester}/tbt_07args.t (98%) create mode 100644 lib/Test/Simple/t/died.t create mode 100644 lib/Test/Simple/t/explain.t create mode 100644 lib/Test/Simple/t/new_ok.t create mode 100644 lib/Test/Simple/t/no_tests.t create mode 100644 lib/Test/Simple/t/note.t delete mode 100644 lib/Test/Simple/t/tbt_04line_num.t diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 1a2cdb0..38a15d4 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -1,20 +1,22 @@ package Test::Builder; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder.pm 67223 2008-10-15T03:08:18.888155Z schwern $ use 5.006; use strict; +use warnings; -our $VERSION = '0.80'; -$VERSION = eval { $VERSION }; # make the alpha version come out as a number +our $VERSION = '0.82'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) # 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'}) { + if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { require threads::shared; - # Hack around YET ANOTHER threads::shared bug. It would + # 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 (\[$@%]) { @@ -22,31 +24,31 @@ BEGIN { my $data; if( $type eq 'HASH' ) { - %$data = %{$_[0]}; + %$data = %{ $_[0] }; } elsif( $type eq 'ARRAY' ) { - @$data = @{$_[0]}; + @$data = @{ $_[0] }; } elsif( $type eq 'SCALAR' ) { - $$data = ${$_[0]}; + $$data = ${ $_[0] }; } else { - die("Unknown type: ".$type); + die( "Unknown type: " . $type ); } - $_[0] = &threads::shared::share($_[0]); + $_[0] = &threads::shared::share( $_[0] ); if( $type eq 'HASH' ) { - %{$_[0]} = %$data; + %{ $_[0] } = %$data; } elsif( $type eq 'ARRAY' ) { - @{$_[0]} = @$data; + @{ $_[0] } = @$data; } elsif( $type eq 'SCALAR' ) { - ${$_[0]} = $$data; + ${ $_[0] } = $$data; } else { - die("Unknown type: ".$type); + die( "Unknown type: " . $type ); } return $_[0]; @@ -60,7 +62,6 @@ BEGIN { } } - =head1 NAME Test::Builder - Backend for building test libraries @@ -110,13 +111,13 @@ singleton, use C. =cut my $Test = Test::Builder->new; + sub new { my($class) = shift; $Test ||= $class->create; return $Test; } - =item B my $Test = Test::Builder->create; @@ -150,10 +151,10 @@ test might be run multiple times in the same process. =cut -use vars qw($Level); +our $Level; -sub reset { - my ($self) = @_; +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. @@ -163,23 +164,25 @@ sub reset { $self->{No_Plan} = 0; $self->{Original_Pid} = $$; - share($self->{Curr_Test}); - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share([]); + 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->{Skip_All} = 0; - $self->{Use_Nums} = 1; + $self->{Use_Nums} = 1; - $self->{No_Header} = 0; - $self->{No_Ending} = 0; + $self->{No_Header} = 0; + $self->{No_Ending} = 0; - $self->{TODO} = undef; + $self->{Todo} = undef; + $self->{Todo_Stack} = []; + $self->{Start_Todo} = 0; - $self->_dup_stdhandles unless $^C; + $self->_dup_stdhandles; return; } @@ -207,36 +210,36 @@ If you call plan(), don't call any of the other methods below. =cut sub plan { - my($self, $cmd, $arg) = @_; + my( $self, $cmd, $arg ) = @_; return unless $cmd; local $Level = $Level + 1; - if( $self->{Have_Plan} ) { - $self->croak("You tried to plan twice"); - } + $self->croak("You tried to plan twice") + if $self->{Have_Plan}; if( $cmd eq 'no_plan' ) { + $self->carp("no_plan takes no arguments") if $arg; $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { - if( $arg ) { + if($arg) { local $Level = $Level + 1; return $self->expected_tests($arg); } elsif( !defined $arg ) { $self->croak("Got an undefined number of tests"); } - elsif( !$arg ) { + else { $self->croak("You said to run 0 tests"); } } else { - my @args = grep { defined } ($cmd, $arg); + my @args = grep { defined } ( $cmd, $arg ); $self->croak("plan() doesn't understand @args"); } @@ -257,9 +260,9 @@ sub expected_tests { my $self = shift; my($max) = @_; - if( @_ ) { + if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") - unless $max =~ /^\+?\d+$/ and $max > 0; + unless $max =~ /^\+?\d+$/; $self->{Expected_Tests} = $max; $self->{Have_Plan} = 1; @@ -269,7 +272,6 @@ sub expected_tests { return $self->{Expected_Tests}; } - =item B $Test->no_plan; @@ -283,6 +285,8 @@ sub no_plan { $self->{No_Plan} = 1; $self->{Have_Plan} = 1; + + return 1; } =item B @@ -296,11 +300,10 @@ Find out whether a plan has been defined. $plan is either C (no plan has sub has_plan { my $self = shift; - return($self->{Expected_Tests}) if $self->{Expected_Tests}; + return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; return('no_plan') if $self->{No_Plan}; return(undef); -}; - +} =item B @@ -312,7 +315,7 @@ Skips all the tests, using the given $reason. Exits immediately with 0. =cut sub skip_all { - my($self, $reason) = @_; + my( $self, $reason ) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; @@ -324,7 +327,6 @@ sub skip_all { exit(0); } - =item B my $pack = $Test->exported_to; @@ -339,7 +341,7 @@ the last one will be honored. =cut sub exported_to { - my($self, $pack) = @_; + my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; @@ -369,7 +371,7 @@ like Test::Simple's ok(). =cut sub ok { - my($self, $test, $name) = @_; + my( $self, $test, $name ) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. @@ -381,27 +383,27 @@ sub ok { $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload_str(\$name); + $self->_unoverload_str( \$name ); - $self->diag(<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 - my $todo = $self->todo(); - # Capture the value of $TODO for the rest of this ok() call # so it can more easily be found by other routines. - local $self->{TODO} = $todo; + my $todo = $self->todo(); + my $in_todo = $self->in_todo; + local $self->{Todo} = $todo if $in_todo; - $self->_unoverload_str(\$todo); + $self->_unoverload_str( \$todo ); my $out; - my $result = &share({}); + my $result = &share( {} ); - unless( $test ) { + unless($test) { $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); @@ -411,16 +413,16 @@ ERR $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } - if( $todo ) { - $out .= " # TODO $todo"; + if( $self->in_todo ) { + $out .= " # TODO $todo"; $result->{reason} = $todo; $result->{type} = 'todo'; } @@ -429,16 +431,16 @@ ERR $result->{type} = ''; } - $self->{Test_Results}[$self->{Curr_Test}-1] = $result; + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; $out .= "\n"; $self->_print($out); - unless( $test ) { - my $msg = $todo ? "Failed (TODO)" : "Failed"; - $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; + 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; + my( undef, $file, $line ) = $self->caller; if( defined $name ) { $self->diag(qq[ $msg test '$name'\n]); $self->diag(qq[ at $file line $line.\n]); @@ -446,64 +448,62 @@ ERR else { $self->diag(qq[ $msg test at $file line $line.\n]); } - } + } return $test ? 1 : 0; } - sub _unoverload { - my $self = shift; - my $type = shift; + my $self = shift; + my $type = shift; - $self->_try(sub { require overload } ) || return; + $self->_try( sub { require overload } ) || return; foreach my $thing (@_) { if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method($$thing, $type) ) { + if( my $string_meth = overload::Method( $$thing, $type ) ) { $$thing = $$thing->$string_meth(); } } } -} + return; +} sub _is_object { - my($self, $thing) = @_; + my( $self, $thing ) = @_; - return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0; + return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; } - sub _unoverload_str { my $self = shift; - $self->_unoverload(q[""], @_); -} + return $self->_unoverload( q[""], @_ ); +} sub _unoverload_num { my $self = shift; - $self->_unoverload('0+', @_); + $self->_unoverload( '0+', @_ ); for my $val (@_) { next unless $self->_is_dualvar($$val); - $$val = $$val+0; + $$val = $$val + 0; } -} + return; +} # This is a hack to detect a dualvar such as $! sub _is_dualvar { - my($self, $val) = @_; + my( $self, $val ) = @_; - local $^W = 0; - my $numval = $val+0; - return 1 if $numval != 0 and $numval ne $val; + no warnings 'numeric'; + my $numval = $val + 0; + return $numval != 0 and $numval ne $val ? 1 : 0; } - - =item B $Test->is_eq($got, $expected, $name); @@ -521,67 +521,85 @@ numeric version. =cut sub is_eq { - my($self, $got, $expect, $name) = @_; + my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_str(\$got, \$expect); + $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; + $self->ok( $test, $name ); + $self->_is_diag( $got, 'eq', $expect ) unless $test; return $test; } - return $self->cmp_ok($got, 'eq', $expect, $name); + return $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { - my($self, $got, $expect, $name) = @_; + my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_num(\$got, \$expect); + $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; + $self->ok( $test, $name ); + $self->_is_diag( $got, '==', $expect ) unless $test; return $test; } - return $self->cmp_ok($got, '==', $expect, $name); + return $self->cmp_ok( $got, '==', $expect, $name ); } -sub _is_diag { - my($self, $got, $type, $expect) = @_; +sub _diag_fmt { + my( $self, $type, $val ) = @_; - foreach my $val (\$got, \$expect) { - if( defined $$val ) { - if( $type eq 'eq' ) { - # quote and force string context - $$val = "'$$val'" - } - else { - # force numeric context - $self->_unoverload_num($val); - } + if( defined $$val ) { + if( $type eq 'eq' or $type eq 'ne' ) { + # quote and force string context + $$val = "'$$val'"; } else { - $$val = 'undef'; + # 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(sprintf <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 @@ -600,38 +618,37 @@ the numeric version. =cut sub isnt_eq { - my($self, $got, $dont_expect, $name) = @_; + 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->_cmp_diag($got, 'ne', $dont_expect) unless $test; + $self->ok( $test, $name ); + $self->_isnt_diag( $got, 'ne' ) unless $test; return $test; } - return $self->cmp_ok($got, 'ne', $dont_expect, $name); + return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { - my($self, $got, $dont_expect, $name) = @_; + 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->_cmp_diag($got, '!=', $dont_expect) unless $test; + $self->ok( $test, $name ); + $self->_isnt_diag( $got, '!=' ) unless $test; return $test; } - return $self->cmp_ok($got, '!=', $dont_expect, $name); + return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } - =item B $Test->like($this, qr/$regex/, $name); @@ -652,20 +669,19 @@ given $regex. =cut sub like { - my($self, $this, $regex, $name) = @_; + my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '=~', $name); + return $self->_regex_ok( $this, $regex, '=~', $name ); } sub unlike { - my($self, $this, $regex, $name) = @_; + my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '!~', $name); + return $self->_regex_ok( $this, $regex, '!~', $name ); } - =item B $Test->cmp_ok($this, $type, $that, $name); @@ -676,28 +692,29 @@ Works just like Test::More's cmp_ok(). =cut - -my %numeric_cmps = map { ($_, 1) } - ("<", "<=", ">", ">=", "==", "!=", "<=>"); +my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); sub cmp_ok { - my($self, $got, $type, $expect, $name) = @_; + my( $self, $got, $type, $expect, $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->$unoverload(\$got, \$expect); + my $unoverload + = $numeric_cmps{$type} + ? '_unoverload_num' + : '_unoverload_str'; + $self->$unoverload( \$got, \$expect ); my $test; { - local($@,$!,$SIG{__DIE__}); # isolate eval + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval my $code = $self->_caller_context; - # Yes, it has to look like this or 5.4.5 won't see the #line + # Yes, it has to look like this or 5.4.5 won't see the #line # directive. # Don't ask me, man, I just work here. $test = eval " @@ -705,38 +722,40 @@ $code" . "\$got $type \$expect;"; } local $Level = $Level + 1; - my $ok = $self->ok($test, $name); + my $ok = $self->ok( $test, $name ); - unless( $ok ) { + unless($ok) { if( $type =~ /^(eq|==)$/ ) { - $self->_is_diag($got, $type, $expect); + $self->_is_diag( $got, $type, $expect ); + } + elsif( $type =~ /^(ne|!=)$/ ) { + $self->_isnt_diag( $got, $type ); } else { - $self->_cmp_diag($got, $type, $expect); + $self->_cmp_diag( $got, $type, $expect ); } } return $ok; } sub _cmp_diag { - my($self, $got, $type, $expect) = @_; - + my( $self, $got, $type, $expect ) = @_; + $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; - + local $Level = $Level + 1; - return $self->diag(sprintf <diag(<<"DIAGNOSTIC"); + $got + $type + $expect DIAGNOSTIC } - sub _caller_context { my $self = shift; - my($pack, $file, $line) = $self->caller(1); + my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; @@ -766,7 +785,7 @@ It will exit with 255. =cut sub BAIL_OUT { - my($self, $reason) = @_; + my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); @@ -780,7 +799,6 @@ BAIL_OUT() used to be BAILOUT() *BAILOUT = \&BAIL_OUT; - =item B $Test->skip; @@ -791,35 +809,36 @@ Skips the current test, reporting $why. =cut sub skip { - my($self, $why) = @_; + my( $self, $why ) = @_; $why ||= ''; - $self->_unoverload_str(\$why); + $self->_unoverload_str( \$why ); $self->_plan_check; - lock($self->{Curr_Test}); + 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, - }); + $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"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # skip"; + $out .= " $why" if length $why; + $out .= "\n"; $self->_print($out); return 1; } - =item B $Test->todo_skip; @@ -833,32 +852,33 @@ to =cut sub todo_skip { - my($self, $why) = @_; + my( $self, $why ) = @_; $why ||= ''; $self->_plan_check; - lock($self->{Curr_Test}); + 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, - }); + $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"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # TODO & SKIP $why\n"; $self->_print($out); return 1; } - =begin _unimplemented =item B @@ -895,7 +915,7 @@ Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding -regular expression, or undef if it's argument is not recognised. +regular expression, or undef if its argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: @@ -910,23 +930,22 @@ could be written as: =cut - sub maybe_regex { - my ($self, $regex) = @_; + my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; - my($re, $opts); + 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 - ) + 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; } @@ -934,35 +953,36 @@ sub maybe_regex { 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( $self, $this, $regex, $cmp, $name ) = @_; - my $ok = 0; + my $ok = 0; my $usable_regex = $self->maybe_regex($regex); - unless (defined $usable_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 $code = $self->_caller_context; - local($@, $!, $SIG{__DIE__}); # isolate eval + local( $@, $!, $SIG{__DIE__} ); # isolate eval - # Yes, it has to look like this or 5.4.5 won't see the #line + # Yes, it has to look like this or 5.4.5 won't see the #line # directive. # Don't ask me, man, I just work here. $test = eval " @@ -974,12 +994,12 @@ $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; $ok = $self->ok( $test, $name ); } - unless( $ok ) { + unless($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; - $self->diag(sprintf <diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); %s %13s '%s' DIAGNOSTIC @@ -989,7 +1009,6 @@ DIAGNOSTIC return $ok; } - # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. @@ -1000,7 +1019,10 @@ DIAGNOSTIC 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. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls. +Works like eval BLOCK except it ensures it has no effect on the rest +of the test (ie. $@ is not set) nor is effected by outside +interference (ie. $SIG{__DIE__}) and works around some quirks in older +Perls. $error is what would normally be in $@. @@ -1009,14 +1031,14 @@ It is suggested you use this in place of eval BLOCK. =cut sub _try { - my($self, $code) = @_; - + my( $self, $code ) = @_; + local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. my $return = eval { $code->() }; - - return wantarray ? ($return, $@) : $return; + + return wantarray ? ( $return, $@ ) : $return; } =end private @@ -1031,19 +1053,18 @@ Determines if the given $thing can be used as a filehandle. =cut sub is_fh { - my $self = shift; + 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 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") } || # 5.5.4's tied() and can() doesn't like getting undef - eval { (tied($maybe_fh) || '')->can('TIEHANDLE') }; + eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; } - =back @@ -1076,7 +1097,7 @@ To be polite to other functions wrapping your own you usually want to increment =cut sub level { - my($self, $level) = @_; + my( $self, $level ) = @_; if( defined $level ) { $Level = $level; @@ -1084,7 +1105,6 @@ sub level { return $Level; } - =item B $Test->use_numbers($on_or_off); @@ -1109,7 +1129,7 @@ Defaults to on. =cut sub use_numbers { - my($self, $use_nums) = @_; + my( $self, $use_nums ) = @_; if( defined $use_nums ) { $self->{Use_Nums} = $use_nums; @@ -1117,7 +1137,6 @@ sub use_numbers { return $self->{Use_Nums}; } - =item B $Test->no_diag($no_diag); @@ -1146,7 +1165,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; my $code = sub { - my($self, $no) = @_; + my( $self, $no ) = @_; if( defined $no ) { $self->{$attribute} = $no; @@ -1154,11 +1173,10 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { return $self->{$attribute}; }; - no strict 'refs'; ## no critic - *{__PACKAGE__.'::'.$method} = $code; + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; } - =back =head2 Output @@ -1197,7 +1215,35 @@ Mark Fowler =cut sub diag { - my($self, @msgs) = @_; + my $self = shift; + + $self->_print_comment( $self->_diag_fh, @_ ); +} + +=item B + + $Test->note(@msgs); + +Like diag(), but it prints to the C 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; @@ -1209,18 +1255,47 @@ sub diag { # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; - # Escape each line with a #. - $msg =~ s/^/# /gm; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\Z/; + # Escape the beginning, _print will take care of the rest. + $msg =~ s/^/# /; local $Level = $Level + 1; - $self->_print_diag($msg); + $self->_print_to_fh( $fh, $msg ); return 0; } +=item B + + my @dump = $Test->explain(@msgs); + +Will dump the contents of any references in a human readable format. +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + is_deeply($have, $want) || note explain $have; + +=cut + +sub explain { + my $self = shift; + + return map { + ref $_ + ? do { + require Data::Dumper; + + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; +} + =begin _private =item B<_print> @@ -1234,7 +1309,12 @@ Prints to the output() filehandle. =cut sub _print { - my($self, @msgs) = @_; + 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 @@ -1242,8 +1322,7 @@ sub _print { my $msg = join '', @msgs; - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->output; + local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. @@ -1252,29 +1331,9 @@ sub _print { # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\Z/; - print $fh $msg; + return print $fh $msg; } -=begin private - -=item B<_print_diag> - - $Test->_print_diag(@msg); - -Like _print, but prints to the current diagnostic filehandle. - -=end private - -=cut - -sub _print_diag { - my $self = shift; - - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - print $fh @_; -} - =item B $Test->output($fh); @@ -1305,7 +1364,7 @@ Defaults to STDOUT. =cut sub output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Out_FH} = $self->_new_fh($fh); @@ -1314,7 +1373,7 @@ sub output { } sub failure_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); @@ -1323,7 +1382,7 @@ sub failure_output { } sub todo_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); @@ -1331,7 +1390,6 @@ sub todo_output { return $self->{Todo_FH}; } - sub _new_fh { my $self = shift; my($file_or_fh) = shift; @@ -1341,24 +1399,25 @@ sub _new_fh { $fh = $file_or_fh; } else { - open $fh, ">", $file_or_fh or - $self->croak("Can't open test output log $file_or_fh: $!"); + 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 ); -my($Testout, $Testerr); sub _dup_stdhandles { my $self = shift; @@ -1367,43 +1426,66 @@ sub _dup_stdhandles { # 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( \*STDOUT ); _autoflush($Testerr); - _autoflush(\*STDERR); + _autoflush( \*STDERR ); - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); -} + $self->reset_outputs; + return; +} my $Opened_Testhandles = 0; + sub _open_testhandles { my $self = shift; - + return if $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: $!"; + 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->_copy_io_layers( \*STDOUT, $Testout ); -# $self->_copy_io_layers( \*STDERR, $Testerr ); - $Opened_Testhandles = 1; -} + return; +} sub _copy_io_layers { - my($self, $src, $dst) = @_; - - $self->_try(sub { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); + 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; - binmode $dst, join " ", map ":$_", @src_layers if @src_layers; - }); + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); + + return; } =item carp @@ -1426,18 +1508,18 @@ sub _message_at_caller { my $self = shift; local $Level = $Level + 1; - my($pack, $file, $line) = $self->caller; - return join("", @_) . " at $file line $line.\n"; + my( $pack, $file, $line ) = $self->caller; + return join( "", @_ ) . " at $file line $line.\n"; } sub carp { my $self = shift; - warn $self->_message_at_caller(@_); + return warn $self->_message_at_caller(@_); } sub croak { my $self = shift; - die $self->_message_at_caller(@_); + return die $self->_message_at_caller(@_); } sub _plan_check { @@ -1447,6 +1529,8 @@ sub _plan_check { local $Level = $Level + 2; $self->croak("You tried to run a test without a plan"); } + + return; } =back @@ -1471,13 +1555,12 @@ can erase history if you really want to. =cut sub current_test { - my($self, $num) = @_; + my( $self, $num ) = @_; - lock($self->{Curr_Test}); + lock( $self->{Curr_Test} ); if( defined $num ) { - unless( $self->{Have_Plan} ) { - $self->croak("Can't change the current test number without a plan!"); - } + $self->croak("Can't change the current test number without a plan!") + unless $self->{Have_Plan}; $self->{Curr_Test} = $num; @@ -1485,14 +1568,16 @@ sub current_test { 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 - }); + 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. @@ -1503,7 +1588,6 @@ sub current_test { return $self->{Curr_Test}; } - =item B my @tests = $Test->summary; @@ -1554,7 +1638,7 @@ of ''. Type can be one of the following: Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so -it's type is 'unkown'. These details for these tests are filled in. +its type is 'unknown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would @@ -1580,10 +1664,13 @@ sub details { my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); -todo() looks for a $TODO variable in your tests. If set, all tests -will be considered 'todo' (see Test::More and Test::Harness for -details). Returns the reason (ie. the value of $TODO) if running as -todo tests, false otherwise. +If the current tests are considered "TODO" it will return the reason, +if any. This reason can come from a $TODO variable or the last call +to C<>. + +Since a TODO test does not need a reason, this function can return an +empty string even when inside a TODO block. Use C<<$Test->in_todo>> +to determine if you are currently inside a TODO block. todo() is about finding the right package to look for $TODO in. It's pretty good at guessing the right package to look at. It first looks for @@ -1597,16 +1684,134 @@ what $pack to use. =cut sub todo { - my($self, $pack) = @_; + 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 - return $self->{TODO} if defined $self->{TODO}; + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack): + +Like C<> but only returns the value of C<<$TODO>> ignoring +C<>. + +=cut + +sub find_TODO { + my( $self, $pack ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; - return 0 unless $pack; + return unless $pack; - no strict 'refs'; ## no critic - return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} - : 0; + no strict 'refs'; ## no critic + return ${ $pack . '::TODO' }; +} + +=item B + + 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 + + $Test->todo_start(); + $Test->todo_start($message); + +This method allows you declare all subsequent tests as TODO tests, up until +the C method has been called. + +The C and C<$TODO> syntax is generally pretty good about figuring out +whether or not we're in a TODO test. However, often we find that this is not +possible to determine (such as when we want to use C<$TODO> but +the tests are being executed in other packages which can't be inferred +beforehand). + +Note that you can use this to nest "todo" tests + + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + +This is generally not recommended, but large testing systems often have weird +internal needs. + +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: + + TODO: { + local $TODO = 'We have work to do!'; + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + } + +Pick one style or another of "TODO" to be on the safe side. + +=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 + + $Test->todo_end; + +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C 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 @@ -1621,11 +1826,11 @@ C<$height> will be added to the level(). =cut -sub caller { - my($self, $height) = @_; +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self, $height ) = @_; $height ||= 0; - my @caller = CORE::caller($self->level + $height + 1); + my @caller = CORE::caller( $self->level + $height + 1 ); return wantarray ? @caller : $caller[0]; } @@ -1651,11 +1856,13 @@ error message. sub _sanity_check { my $self = shift; - $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); - $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, - 'Somehow your tests ran without a plan!'); - $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!'); + $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); + $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test}, + 'Somehow your tests ran without a plan!' ); + $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, + 'Somehow you got a different number of results than tests ran!' ); + + return; } =item B<_whoa> @@ -1669,14 +1876,16 @@ a note to contact the author. =cut sub _whoa { - my($self, $check, $desc) = @_; - if( $check ) { + 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> @@ -1691,12 +1900,11 @@ doesn't actually exit, that's your job. =cut sub _my_exit { - $? = $_[0]; + $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) return 1; } - =back =end _private @@ -1714,8 +1922,8 @@ sub _ending { if( $self->{Original_Pid} != $$ ) { return; } - - # Exit if plan() was never called. This is so "require Test::Simple" + + # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. if( !$self->{Have_Plan} ) { return; @@ -1728,7 +1936,7 @@ sub _ending { # Figure out if we passed or failed and print helpful messages. my $test_results = $self->{Test_Results}; - if( @$test_results ) { + if(@$test_results) { # The plan? We have no plan. if( $self->{No_Plan} ) { $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; @@ -1738,31 +1946,24 @@ sub _ending { # 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 ) { + 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_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - if( $num_extra < 0 ) { + if( $num_extra != 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. -FAIL - } - elsif( $num_extra > 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. +Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. FAIL } - if ( $num_failed ) { + if($num_failed) { my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; @@ -1773,16 +1974,16 @@ Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } - if( $real_exit_code ) { + if($real_exit_code) { $self->diag(<<"FAIL"); -Looks like your test died just after $self->{Curr_Test}. +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. FAIL - _my_exit( 255 ) && return; + _my_exit($real_exit_code) && return; } my $exit_code; - if( $num_failed ) { + if($num_failed) { $exit_code = $num_failed <= 254 ? $num_failed : 254; } elsif( $num_extra != 0 ) { @@ -1792,21 +1993,23 @@ FAIL $exit_code = 0; } - _my_exit( $exit_code ) && return; + _my_exit($exit_code) && return; } - elsif ( $self->{Skip_All} ) { - _my_exit( 0 ) && return; + elsif( $self->{Skip_All} ) { + _my_exit(0) && return; } - elsif ( $real_exit_code ) { - $self->diag(<<'FAIL'); -Looks like your test died before it could output anything. + elsif($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code before it could output anything. FAIL - _my_exit( 255 ) && return; + _my_exit($real_exit_code) && return; } else { $self->diag("No tests run!\n"); - _my_exit( 255 ) && return; + _my_exit(255) && return; } + + $self->_whoa( 1, "We fell off the end of _ending()" ); } END { @@ -1860,8 +2063,8 @@ Eschwern@pobox.comE =head1 COPYRIGHT -Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and - Michael G Schwern Eschwern@pobox.comE. +Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and + Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -1871,3 +2074,4 @@ See F =cut 1; + diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm index ea2f2d9..c5e36e8 100644 --- a/lib/Test/Builder/Module.pm +++ b/lib/Test/Builder/Module.pm @@ -1,4 +1,5 @@ package Test::Builder::Module; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Module.pm 67223 2008-10-15T03:08:18.888155Z schwern $ use strict; @@ -7,18 +8,17 @@ use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '0.80'; +our $VERSION = '0.82'; # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { - my $pkg = shift; - my $level = shift; - (undef) = shift; # redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); }; - =head1 NAME Test::Builder::Module - Base class for test modules @@ -83,7 +83,7 @@ import_extra(). sub import { my($class) = shift; - + # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; @@ -93,27 +93,26 @@ sub import { $test->exported_to($caller); - $class->import_extra(\@_); - my(@imports) = $class->_strip_imports(\@_); + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); - $class->$_export_to_level(1, $class, @imports); + $class->$_export_to_level( 1, $class, @imports ); } - sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); - my $idx = 0; + my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { - push @imports, @{$list->[$idx+1]}; + push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { @@ -128,7 +127,6 @@ sub _strip_imports { return @imports; } - =head3 import_extra Your::Module->import_extra(\@import_args); @@ -146,8 +144,7 @@ feels like a bit of an ugly hack in its current form. =cut -sub import_extra {} - +sub import_extra { } =head2 Builder @@ -181,5 +178,4 @@ sub builder { return Test::Builder->new; } - 1; diff --git a/lib/Test/Builder/Tester.pm b/lib/Test/Builder/Tester.pm index fdb3fb1..772775e 100644 --- a/lib/Test/Builder/Tester.pm +++ b/lib/Test/Builder/Tester.pm @@ -1,7 +1,8 @@ package Test::Builder::Tester; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Tester.pm 67223 2008-10-15T03:08:18.888155Z schwern $ use strict; -our $VERSION = "1.13"; +our $VERSION = "1.15"; use Test::Builder; use Symbol; @@ -63,13 +64,12 @@ our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); # the king of cargo cult programming ;-) # 5.004's Exporter doesn't have export_to_level. -sub _export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # XXX redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); +sub _export_to_level { + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); } sub import { @@ -82,14 +82,14 @@ sub import { $t->plan(@plan); my @imports = (); - foreach my $idx (0..$#plan) { + foreach my $idx ( 0 .. $#plan ) { if( $plan[$idx] eq 'import' ) { - @imports = @{$plan[$idx+1]}; + @imports = @{ $plan[ $idx + 1 ] }; last; } } - __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); + __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports ); } ### @@ -123,8 +123,7 @@ my $original_harness_state; my $original_harness_env; # function that starts testing and redirects the filehandles for now -sub _start_testing -{ +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; @@ -145,7 +144,7 @@ sub _start_testing $err->reset(); # remeber that we're testing - $testing = 1; + $testing = 1; $testing_num = $t->current_test; $t->current_test(0); @@ -187,20 +186,18 @@ output filehandles) =cut -sub test_out -{ +sub test_out { # do we need to do any setup? _start_testing() unless $testing; - $out->expect(@_) + $out->expect(@_); } -sub test_err -{ +sub test_err { # do we need to do any setup? _start_testing() unless $testing; - $err->expect(@_) + $err->expect(@_); } =item test_fail @@ -229,14 +226,13 @@ more simply as: =cut -sub test_fail -{ +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 + my( $package, $filename, $line ) = caller; + $line = $line + ( shift() || 0 ); # prevent warnings # expect that on stderr $err->expect("# Failed test ($0 at line $line)"); @@ -272,14 +268,13 @@ without the newlines. =cut -sub test_diag -{ +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 {"# $_"} @_) + $err->expect( map { "# $_" } @_ ); } =item test_test @@ -321,24 +316,23 @@ will function normally and cause success/errors for B. =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}); - } +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; + unless $testing; # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); @@ -353,20 +347,20 @@ sub test_test $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)) + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) + ) { - # print out the diagnostic information about why this - # test failed + # print out the diagnostic information about why this + # test failed - local $_; + local $_; - $t->diag(map {"$_\n"} $out->complaint) - unless $args{skip_out} || $out->check; + $t->diag( map { "$_\n" } $out->complaint ) + unless $args{skip_out} || $out->check; - $t->diag(map {"$_\n"} $err->complaint) - unless $args{skip_err} || $err->check; + $t->diag( map { "$_\n" } $err->complaint ) + unless $args{skip_err} || $err->check; } } @@ -382,10 +376,9 @@ C idiom is arguably nicer. =cut -sub line_num -{ - my ($package, $filename, $line) = caller; - return $line + (shift() || 0); # prevent warnings +sub line_num { + my( $package, $filename, $line ) = caller; + return $line + ( shift() || 0 ); # prevent warnings } =back @@ -431,10 +424,10 @@ the PERL5LIB. =cut my $color; -sub color -{ - $color = shift if @_; - $color; + +sub color { + $color = shift if @_; + $color; } =back @@ -489,21 +482,18 @@ package Test::Builder::Tester::Tie; ## # add line(s) to be expected -sub expect -{ +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"; + push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; } } - -sub _translate_Failed_check -{ - my($self, $check) = @_; +sub _translate_Failed_check { + my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; @@ -512,21 +502,19 @@ sub _translate_Failed_check return $check; } - ## # return true iff the expected data matches the got data -sub check -{ +sub check { my $self = shift; # turn off warnings as these might be undef local $^W = 0; - my @checks = @{$self->{wanted}}; - my $got = $self->{got}; + my @checks = @{ $self->{wanted} }; + my $got = $self->{got}; foreach my $check (@checks) { - $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check); + $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); return 0 unless $got =~ s/^$check//; } @@ -537,82 +525,71 @@ sub check # a complaint message about the inputs not matching (to be # used for debugging messages) -sub complaint -{ - my $self = shift; +sub complaint { + my $self = shift; my $type = $self->type; my $got = $self->got; - my $wanted = join "\n", @{$self->wanted}; + 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; - } + 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" + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data -sub reset -{ +sub reset { my $self = shift; %$self = ( - type => $self->{type}, - got => '', - wanted => [], - ); + type => $self->{type}, + got => '', + wanted => [], + ); } - -sub got -{ +sub got { my $self = shift; return $self->{got}; } -sub wanted -{ +sub wanted { my $self = shift; return $self->{wanted}; } -sub type -{ +sub type { my $self = shift; return $self->{type}; } @@ -621,26 +598,24 @@ sub type # tie interface ### -sub PRINT { +sub PRINT { my $self = shift; $self->{got} .= join '', @_; } sub TIEHANDLE { - my($class, $type) = @_; + my( $class, $type ) = @_; - my $self = bless { - type => $type - }, $class; + my $self = bless { type => $type }, $class; $self->reset; return $self; } -sub READ {} -sub READLINE {} -sub GETC {} -sub FILENO {} +sub READ { } +sub READLINE { } +sub GETC { } +sub FILENO { } 1; diff --git a/lib/Test/Builder/Tester/Color.pm b/lib/Test/Builder/Tester/Color.pm index b479e71..27fc868 100644 --- a/lib/Test/Builder/Tester/Color.pm +++ b/lib/Test/Builder/Tester/Color.pm @@ -1,4 +1,5 @@ package Test::Builder::Tester::Color; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Tester/Color.pm 67132 2008-10-01T01:11:04.501643Z schwern $ use strict; @@ -25,8 +26,7 @@ from the command line. =cut -sub import -{ +sub import { Test::Builder::Tester::color(1); } diff --git a/lib/Test/More.pm b/lib/Test/More.pm index 5842e05..0186397 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -1,38 +1,40 @@ package Test::More; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/More.pm 67223 2008-10-15T03:08:18.888155Z schwern $ 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]; - warn @_, " at $file line $line\n"; + my( $file, $line ) = ( caller(1) )[ 1, 2 ]; + return warn @_, " at $file line $line\n"; } - - -use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.80'; -$VERSION = eval $VERSION; # make the alpha version come out as a number +our $VERSION = '0.82'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; -@ISA = qw(Test::Builder::Module); -@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 - can_ok isa_ok - diag - BAIL_OUT - ); - +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 + can_ok isa_ok new_ok + diag note explain + BAIL_OUT +); =head1 NAME @@ -158,10 +160,9 @@ or for deciding between running the tests at all: sub plan { my $tb = Test::More->builder; - $tb->plan(@_); + return $tb->plan(@_); } - # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { @@ -169,7 +170,7 @@ sub import_extra { my $list = shift; my @other = (); - my $idx = 0; + my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; @@ -184,8 +185,9 @@ sub import_extra { } @$list = @other; -} + return; +} =head2 Test names @@ -256,10 +258,10 @@ This is the same as Test::Simple's ok() routine. =cut sub ok ($;$) { - my($test, $name) = @_; + my( $test, $name ) = @_; my $tb = Test::More->builder; - $tb->ok($test, $name); + return $tb->ok( $test, $name ); } =item B @@ -325,18 +327,17 @@ function which is an alias of isnt(). sub is ($$;$) { my $tb = Test::More->builder; - $tb->is_eq(@_); + return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; - $tb->isnt_eq(@_); + return $tb->isnt_eq(@_); } *isn't = \&isnt; - =item B like( $got, qr/expected/, $test_name ); @@ -370,10 +371,9 @@ diagnostics on failure. sub like ($$;$) { my $tb = Test::More->builder; - $tb->like(@_); + return $tb->like(@_); } - =item B unlike( $got, qr/expected/, $test_name ); @@ -386,10 +386,9 @@ given pattern. sub unlike ($$;$) { my $tb = Test::More->builder; - $tb->unlike(@_); + return $tb->unlike(@_); } - =item B cmp_ok( $got, $op, $expected, $test_name ); @@ -426,10 +425,9 @@ is()'s use of C will interfere: sub cmp_ok($$$;$) { my $tb = Test::More->builder; - $tb->cmp_ok(@_); + return $tb->cmp_ok(@_); } - =item B can_ok($module, @methods); @@ -460,17 +458,17 @@ as one test. If you desire otherwise, use: =cut sub can_ok ($@) { - my($proto, @methods) = @_; + my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; - unless( $class ) { + unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } - unless( @methods ) { + unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; @@ -478,16 +476,15 @@ sub can_ok ($@) { my @nok = (); foreach my $method (@methods) { - $tb->_try(sub { $proto->can($method) }) or push @nok, $method; + $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; + my $name = (@methods == 1) ? "$class->can('$methods[0]')" : + "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); - $tb->diag(map " $class->can('$_') failed\n", @nok); + $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } @@ -522,7 +519,7 @@ you'd like them to be more specific, you can supply an $object_name =cut sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; + my( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; @@ -536,15 +533,16 @@ sub isa_ok ($$;$) { } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides - my($rslt, $error) = $tb->_try(sub { $object->isa($class) }); - if( $error ) { + 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 - if( !UNIVERSAL::isa($object, $class) ) { + if( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } - } else { + } + else { die <isa on your object and got some weird error. Here's the error. @@ -557,11 +555,9 @@ WHOA $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } - - my $ok; - if( $diag ) { + if($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } @@ -572,6 +568,49 @@ WHOA return $ok; } +=item B + + my $obj = new_ok( $class ); + my $obj = new_ok( $class => \@args ); + my $obj = new_ok( $class => \@args, $object_name ); + +A convenience function which combines creating an object and calling +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 @@ -592,12 +631,14 @@ Use these very, very, very sparingly. sub pass (;$) { my $tb = Test::More->builder; - $tb->ok(1, @_); + + return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; - $tb->ok(0, @_); + + return $tb->ok( 0, @_ ); } =back @@ -652,11 +693,11 @@ because the notion of "compile-time" is relative. Instead, you want: =cut sub use_ok ($;@) { - my($module, @imports) = @_; + my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; - my($pack,$filename,$line) = caller; + my( $pack, $filename, $line ) = caller; my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { @@ -676,11 +717,10 @@ use $module \@{\$args[0]}; USE } - - my($eval_result, $eval_error) = _eval($code, \@imports); + my( $eval_result, $eval_error ) = _eval( $code, \@imports ); my $ok = $tb->ok( $eval_result, "use $module;" ); - - unless( $ok ) { + + unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; @@ -694,18 +734,22 @@ DIAGNOSTIC return $ok; } - sub _eval { - my($code) = shift; - my @args = @_; + my( $code, @args ) = @_; # Work around oddities surrounding resetting of $@ by immediately # storing it. - local($@,$!,$SIG{__DIE__}); # isolate eval - my $eval_result = eval $code; - my $eval_error = $@; + 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); + return( $eval_result, $eval_error ); } =item B @@ -733,10 +777,10 @@ require $module; 1; REQUIRE - my($eval_result, $eval_error) = _eval($code); + my( $eval_result, $eval_error ) = _eval($code); my $ok = $tb->ok( $eval_result, "require $module;" ); - unless( $ok ) { + unless($ok) { chomp $eval_error; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { - my $msg = <ok(0); + return $tb->ok(0); } - my($got, $expected, $name) = @_; + my( $got, $expected, $name ) = @_; - $tb->_unoverload_str(\$expected, \$got); + $tb->_unoverload_str( \$expected, \$got ); my $ok; - if( !ref $got and !ref $expected ) { # neither is a reference - $ok = $tb->is_eq($got, $expected, $name); + 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 ] }) ); + 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 + else { # both references local @Data_Stack = (); - if( _deep_check($got, $expected) ) { - $ok = $tb->ok(1, $name); + if( _deep_check( $got, $expected ) ) { + $ok = $tb->ok( 1, $name ); } else { - $ok = $tb->ok(0, $name); - $tb->diag(_format_stack(@Data_Stack)); + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack(@Data_Stack) ); } } @@ -847,11 +891,11 @@ WARNING sub _format_stack { my(@Stack) = @_; - my $var = '$FOO'; + my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; - my $idx = $entry->{'idx'}; + my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; @@ -865,18 +909,19 @@ sub _format_stack { } } - my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); - ($vars[0] = $var) =~ s/\$FOO/ \$got/; - ($vars[1] = $var) =~ s/\$FOO/\$expected/; + ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; + ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; - foreach my $idx (0..$#vals) { + foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; - $vals[$idx] = !defined $val ? 'undef' : - _dne($val) ? "Does not exist" : - ref $val ? "$val" : - "'$val'"; + $vals[$idx] + = !defined $val ? 'undef' + : _dne($val) ? "Does not exist" + : ref $val ? "$val" + : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; @@ -886,14 +931,13 @@ sub _format_stack { 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 $type if UNIVERSAL::isa( $thing, $type ); } return ''; @@ -919,6 +963,8 @@ Prints a diagnostic message which is guaranteed not to interfere with test output. Like C @diagnostic_message is simply concatenated together. +Returns false, so as to preserve failure. + Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or @@ -938,14 +984,49 @@ B 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(@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 { - my $tb = Test::More->builder; + return Test::More->builder->diag(@_); +} - $tb->diag(@_); +sub note { + return Test::More->builder->note(@_); } +=item B + + my @dump = explain @diagnostic_message; + +Will dump the contents of any references in a human readable format. +Usually you want to pass this into C or C. + +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + note explain \%args; + Some::Class->method(%args); + +=cut + +sub explain { + return Test::More->builder->explain(@_); +} =back @@ -1009,9 +1090,9 @@ use TODO. Read on. =cut -#'# +## no critic (Subroutines::RequireFinalReturn) sub skip { - my($why, $how_many) = @_; + my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { @@ -1022,19 +1103,19 @@ sub skip { } if( defined $how_many and $how_many =~ /\D/ ) { - _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; + _carp + "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } - for( 1..$how_many ) { + for( 1 .. $how_many ) { $tb->skip($why); } - local $^W = 0; + no warnings 'exiting'; last SKIP; } - =item B TODO: { @@ -1097,7 +1178,7 @@ interpret them as passing. =cut sub todo_skip { - my($why, $how_many) = @_; + my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { @@ -1107,11 +1188,11 @@ sub todo_skip { $how_many = 1; } - for( 1..$how_many ) { + for( 1 .. $how_many ) { $tb->todo_skip($why); } - local $^W = 0; + no warnings 'exiting'; last TODO; } @@ -1151,7 +1232,7 @@ The test will exit with 255. sub BAIL_OUT { my $reason = shift; - my $tb = Test::More->builder; + my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } @@ -1190,14 +1271,14 @@ multi-level structures are handled correctly. #'# sub eq_array { - local @Data_Stack; + local @Data_Stack = (); _deep_check(@_); } -sub _eq_array { - my($a1, $a2) = @_; +sub _eq_array { + my( $a1, $a2 ) = @_; - if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { + if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } @@ -1206,12 +1287,12 @@ sub _eq_array { my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; - for (0..$max) { + 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); + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; @@ -1221,7 +1302,7 @@ sub _eq_array { } sub _deep_check { - my($e1, $e2) = @_; + my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; @@ -1233,27 +1314,27 @@ sub _deep_check { { # Quiet uninitialized value warnings when comparing undefs. - local $^W = 0; + no warnings 'uninitialized'; - $tb->_unoverload_str(\$e1, \$e2); + $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); + 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 ( _dne($e1) xor _dne($e2) ) { + elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } - elsif ( $same_ref and ($e1 eq $e2) ) { + elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } - elsif ( $not_ref ) { - push @Data_Stack, { type => '', vals => [$e1, $e2] }; - $ok = 0; - } + elsif($not_ref) { + push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; + $ok = 0; + } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; @@ -1266,50 +1347,48 @@ sub _deep_check { $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { - $ok = _eq_array($e1, $e2); + $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { - $ok = _eq_hash($e1, $e2); + $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); + 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); + 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] }; + elsif($type) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } - else { - _whoa(1, "No type in _deep_check"); - } + else { + _whoa( 1, "No type in _deep_check" ); + } } } return $ok; } - sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die < my $is_eq = eq_hash(\%got, \%expected); @@ -1320,14 +1399,14 @@ is a deep check. =cut sub eq_hash { - local @Data_Stack; + local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { - my($a1, $a2) = @_; + my( $a1, $a2 ) = @_; - if( grep !_type($_) eq 'HASH', $a1, $a2 ) { + if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } @@ -1336,12 +1415,12 @@ sub _eq_hash { my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - foreach my $k (keys %$bigger) { + 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); + push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; @@ -1376,14 +1455,13 @@ Test::Deep contains much better set comparison functions. =cut -sub eq_set { - my($a1, $a2) = @_; +sub eq_set { + my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; - # There's faster ways to do this, but this is easiest. - local $^W = 0; + no warnings 'uninitialized'; - # It really doesn't matter how we sort them, as long as both arrays are + # 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 @@ -1395,8 +1473,8 @@ sub eq_set { # 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) )], + [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], + [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } @@ -1522,21 +1600,21 @@ L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). -L is the old testing module. Its main benefit is that it has -been distributed with Perl since 5.004_05. +L is the test runner and output interpreter for Perl. +It's the thing that powers C and where the C utility +comes from. -L for details on how your test results are interpreted -by Perl. +L tests written with Test.pm, the original testing +module, do not play well with other testing libraries. Test::Legacy +emulates the Test.pm interface and does play well with others. L for more ways to test complex data structures. And it plays well with Test::More. -L is like XUnit but more perlish. +L is like xUnit but more perlish. L gives you more powerful complex data structure testing. -L is XUnit style testing. - L shows the idea of embedded testing. L installs a whole bunch of useful test modules. @@ -1557,7 +1635,7 @@ See F to report and view bugs. =head1 COPYRIGHT -Copyright 2001-2002, 2004-2006 by Michael G Schwern Eschwern@pobox.comE. +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index e4799ca..606d7fb 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -1,19 +1,19 @@ package Test::Simple; +# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Simple.pm 67223 2008-10-15T03:08:18.888155Z schwern $ use 5.004; -use strict 'vars'; -use vars qw($VERSION @ISA @EXPORT); -$VERSION = '0.80'; -$VERSION = eval $VERSION; # make the alpha version come out as a number +use strict; + +our $VERSION = '0.82'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; -@ISA = qw(Test::Builder::Module); -@EXPORT = qw(ok); +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); my $CLASS = __PACKAGE__; - =head1 NAME Test::Simple - Basic utilities for writing tests. @@ -77,11 +77,10 @@ will do what you mean (fail if stuff is empty) =cut -sub ok ($;$) { - $CLASS->builder->ok(@_); +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + return $CLASS->builder->ok(@_); } - =back Test::Simple will start by printing number of tests run in the form @@ -191,24 +190,10 @@ 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). -=item L - -The original Perl testing module. - -=item L - -Elaborate unit testing. - -=item L, L - -Embed tests in your code! - -=item L - -Interprets the output of your test program. - =back +Look in Test::More's SEE ALSO for more testing modules. + =head1 AUTHORS @@ -218,7 +203,7 @@ Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT -Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Test/Simple/t/00test_harness_check.t b/lib/Test/Simple/t/00test_harness_check.t index 3ff4a13..ee5c11a 100644 --- a/lib/Test/Simple/t/00test_harness_check.t +++ b/lib/Test/Simple/t/00test_harness_check.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/00test_harness_check.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ # A test to make sure the new Test::Harness was installed properly. diff --git a/lib/Test/Simple/t/BEGIN_require_ok.t b/lib/Test/Simple/t/BEGIN_require_ok.t index 289ebc5..a06ca1b 100644 --- a/lib/Test/Simple/t/BEGIN_require_ok.t +++ b/lib/Test/Simple/t/BEGIN_require_ok.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/BEGIN_require_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/BEGIN_use_ok.t b/lib/Test/Simple/t/BEGIN_use_ok.t index 26caaa1..d6baefe 100644 --- a/lib/Test/Simple/t/BEGIN_use_ok.t +++ b/lib/Test/Simple/t/BEGIN_use_ok.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/BEGIN_use_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ # [rt.cpan.org 28345] # diff --git a/lib/Test/Simple/t/Builder.t b/lib/Test/Simple/t/Builder/Builder.t similarity index 86% rename from lib/Test/Simple/t/Builder.t rename to lib/Test/Simple/t/Builder/Builder.t index a5bfd15..24e395c 100644 --- a/lib/Test/Simple/t/Builder.t +++ b/lib/Test/Simple/t/Builder/Builder.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/Builder.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/carp.t b/lib/Test/Simple/t/Builder/carp.t similarity index 85% rename from lib/Test/Simple/t/carp.t rename to lib/Test/Simple/t/Builder/carp.t index e89eeeb..a390aa6 100644 --- a/lib/Test/Simple/t/carp.t +++ b/lib/Test/Simple/t/Builder/carp.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Builder/carp.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/create.t b/lib/Test/Simple/t/Builder/create.t similarity index 89% rename from lib/Test/Simple/t/create.t rename to lib/Test/Simple/t/Builder/create.t index 5600d68..d923227 100644 --- a/lib/Test/Simple/t/create.t +++ b/lib/Test/Simple/t/Builder/create.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/create.t 60332 2008-09-09T12:24:03.060291Z schwern $ #!perl -w diff --git a/lib/Test/Simple/t/curr_test.t b/lib/Test/Simple/t/Builder/curr_test.t similarity index 71% rename from lib/Test/Simple/t/curr_test.t rename to lib/Test/Simple/t/Builder/curr_test.t index edd201c..9607db3 100644 --- a/lib/Test/Simple/t/curr_test.t +++ b/lib/Test/Simple/t/Builder/curr_test.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/curr_test.t 60332 2008-09-09T12:24:03.060291Z schwern $ # Dave Rolsky found a bug where if current_test() is used and no # tests are run via Test::Builder it will blow up. diff --git a/lib/Test/Simple/t/details.t b/lib/Test/Simple/t/Builder/details.t similarity index 96% rename from lib/Test/Simple/t/details.t rename to lib/Test/Simple/t/Builder/details.t index bd0ea9b..0f3c31d 100644 --- a/lib/Test/Simple/t/details.t +++ b/lib/Test/Simple/t/Builder/details.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/details.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/has_plan.t b/lib/Test/Simple/t/Builder/has_plan.t similarity index 78% rename from lib/Test/Simple/t/has_plan.t rename to lib/Test/Simple/t/Builder/has_plan.t index d0be86a..9c8ae59 100644 --- a/lib/Test/Simple/t/has_plan.t +++ b/lib/Test/Simple/t/Builder/has_plan.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/has_plan.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/has_plan2.t b/lib/Test/Simple/t/Builder/has_plan2.t similarity index 77% rename from lib/Test/Simple/t/has_plan2.t rename to lib/Test/Simple/t/Builder/has_plan2.t index e13ea4a..eaceeca 100644 --- a/lib/Test/Simple/t/has_plan2.t +++ b/lib/Test/Simple/t/Builder/has_plan2.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/has_plan2.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/is_fh.t b/lib/Test/Simple/t/Builder/is_fh.t similarity index 90% rename from lib/Test/Simple/t/is_fh.t rename to lib/Test/Simple/t/Builder/is_fh.t index 0eb3ec0..ab8b887 100644 --- a/lib/Test/Simple/t/is_fh.t +++ b/lib/Test/Simple/t/Builder/is_fh.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/is_fh.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/Builder/maybe_regex.t similarity index 92% rename from lib/Test/Simple/t/maybe_regex.t rename to lib/Test/Simple/t/Builder/maybe_regex.t index d1927a5..5741220 100644 --- a/lib/Test/Simple/t/maybe_regex.t +++ b/lib/Test/Simple/t/Builder/maybe_regex.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/maybe_regex.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/no_diag.t b/lib/Test/Simple/t/Builder/no_diag.t similarity index 59% rename from lib/Test/Simple/t/no_diag.t rename to lib/Test/Simple/t/Builder/no_diag.t index 6fa538a..07cb3ba 100644 --- a/lib/Test/Simple/t/no_diag.t +++ b/lib/Test/Simple/t/Builder/no_diag.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/no_diag.t 60332 2008-09-09T12:24:03.060291Z schwern $ use Test::More 'no_diag', tests => 2; diff --git a/lib/Test/Simple/t/no_ending.t b/lib/Test/Simple/t/Builder/no_ending.t similarity index 76% rename from lib/Test/Simple/t/no_ending.t rename to lib/Test/Simple/t/Builder/no_ending.t index 97e968e..fe3edec 100644 --- a/lib/Test/Simple/t/no_ending.t +++ b/lib/Test/Simple/t/Builder/no_ending.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/Builder/no_ending.t 60332 2008-09-09T12:24:03.060291Z schwern $ use Test::Builder; BEGIN { diff --git a/lib/Test/Simple/t/no_header.t b/lib/Test/Simple/t/Builder/no_header.t similarity index 74% rename from lib/Test/Simple/t/no_header.t rename to lib/Test/Simple/t/Builder/no_header.t index 93e6bec..3992f0f 100644 --- a/lib/Test/Simple/t/no_header.t +++ b/lib/Test/Simple/t/Builder/no_header.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/Builder/no_header.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/ok_obj.t b/lib/Test/Simple/t/Builder/ok_obj.t similarity index 82% rename from lib/Test/Simple/t/ok_obj.t rename to lib/Test/Simple/t/Builder/ok_obj.t index 8678dbf..9dc658a 100644 --- a/lib/Test/Simple/t/ok_obj.t +++ b/lib/Test/Simple/t/Builder/ok_obj.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/ok_obj.t 60332 2008-09-09T12:24:03.060291Z schwern $ # Testing to make sure Test::Builder doesn't accidentally store objects # passed in as test arguments. diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/Builder/output.t similarity index 94% rename from lib/Test/Simple/t/output.t rename to lib/Test/Simple/t/Builder/output.t index 598d805..4dc0d2e 100644 --- a/lib/Test/Simple/t/output.t +++ b/lib/Test/Simple/t/Builder/output.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/output.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/reset.t b/lib/Test/Simple/t/Builder/reset.t similarity index 95% rename from lib/Test/Simple/t/reset.t rename to lib/Test/Simple/t/Builder/reset.t index 5a7b07f..5284fb3 100644 --- a/lib/Test/Simple/t/reset.t +++ b/lib/Test/Simple/t/Builder/reset.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/reset.t 60332 2008-09-09T12:24:03.060291Z schwern $ # Test Test::Builder->reset; diff --git a/lib/Test/Simple/t/try.t b/lib/Test/Simple/t/Builder/try.t similarity index 82% rename from lib/Test/Simple/t/try.t rename to lib/Test/Simple/t/Builder/try.t index 6e753a4..87a903f 100644 --- a/lib/Test/Simple/t/try.t +++ b/lib/Test/Simple/t/Builder/try.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/Builder/try.t 60332 2008-09-09T12:24:03.060291Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -32,4 +33,4 @@ is_deeply [$tb->_try(sub { die "Foo\n" }, undef)], [undef, "Foo\n"]; is $@, 42; -cmp_ok $!, '==', 23; \ No newline at end of file +cmp_ok $!, '==', 23; diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index eabd0fa..c84bf2c 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/More.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/tbt_01basic.t b/lib/Test/Simple/t/Tester/tbt_01basic.t similarity index 84% rename from lib/Test/Simple/t/tbt_01basic.t rename to lib/Test/Simple/t/Tester/tbt_01basic.t index 769a1c4..575a92b 100644 --- a/lib/Test/Simple/t/tbt_01basic.t +++ b/lib/Test/Simple/t/Tester/tbt_01basic.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_01basic.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::Builder::Tester tests => 9; use Test::More; @@ -22,7 +23,7 @@ ok(2,"two"); test_test("multiple tests"); test_out("not ok 1 - should fail"); -test_err("# Failed test ($0 at line 28)"); +test_err("# Failed test ($0 at line 29)"); test_err("# got: 'foo'"); test_err("# expected: 'bar'"); is("foo","bar","should fail"); @@ -46,7 +47,7 @@ test_test("testing failing on the same line with the same name"); test_out("not ok 1 - name # TODO Something"); -test_err("# Failed (TODO) test ($0 at line 52)"); +test_err("# Failed (TODO) test ($0 at line 53)"); TODO: { local $TODO = "Something"; fail("name"); diff --git a/lib/Test/Simple/t/tbt_02fhrestore.t b/lib/Test/Simple/t/Tester/tbt_02fhrestore.t similarity index 91% rename from lib/Test/Simple/t/tbt_02fhrestore.t rename to lib/Test/Simple/t/Tester/tbt_02fhrestore.t index e373571..398ac0e 100644 --- a/lib/Test/Simple/t/tbt_02fhrestore.t +++ b/lib/Test/Simple/t/Tester/tbt_02fhrestore.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_02fhrestore.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::Builder::Tester tests => 4; use Test::More; diff --git a/lib/Test/Simple/t/tbt_03die.t b/lib/Test/Simple/t/Tester/tbt_03die.t similarity index 68% rename from lib/Test/Simple/t/tbt_03die.t rename to lib/Test/Simple/t/Tester/tbt_03die.t index b9dba80..5657f2a 100644 --- a/lib/Test/Simple/t/tbt_03die.t +++ b/lib/Test/Simple/t/Tester/tbt_03die.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_03die.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::Builder::Tester tests => 1; use Test::More; diff --git a/lib/Test/Simple/t/Tester/tbt_04line_num.t b/lib/Test/Simple/t/Tester/tbt_04line_num.t new file mode 100644 index 0000000..1988b2d --- /dev/null +++ b/lib/Test/Simple/t/Tester/tbt_04line_num.t @@ -0,0 +1,9 @@ +#!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_04line_num.t 60331 2008-09-09T12:17:12.607612Z schwern $ + +use Test::More tests => 3; +use Test::Builder::Tester; + +is(line_num(),7,"normal line num"); +is(line_num(-1),7,"line number minus one"); +is(line_num(+2),11,"line number plus two"); diff --git a/lib/Test/Simple/t/tbt_05faildiag.t b/lib/Test/Simple/t/Tester/tbt_05faildiag.t similarity index 88% rename from lib/Test/Simple/t/tbt_05faildiag.t rename to lib/Test/Simple/t/Tester/tbt_05faildiag.t index 59ad721..ffeb5d5 100644 --- a/lib/Test/Simple/t/tbt_05faildiag.t +++ b/lib/Test/Simple/t/Tester/tbt_05faildiag.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_05faildiag.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::Builder::Tester tests => 5; use Test::More; diff --git a/lib/Test/Simple/t/tbt_06errormess.t b/lib/Test/Simple/t/Tester/tbt_06errormess.t similarity index 96% rename from lib/Test/Simple/t/tbt_06errormess.t rename to lib/Test/Simple/t/Tester/tbt_06errormess.t index d8d8a0f..da3bbef 100644 --- a/lib/Test/Simple/t/tbt_06errormess.t +++ b/lib/Test/Simple/t/Tester/tbt_06errormess.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_06errormess.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::More tests => 8; use Symbol; diff --git a/lib/Test/Simple/t/tbt_07args.t b/lib/Test/Simple/t/Tester/tbt_07args.t similarity index 98% rename from lib/Test/Simple/t/tbt_07args.t rename to lib/Test/Simple/t/Tester/tbt_07args.t index 1b9393b..ac5f414 100644 --- a/lib/Test/Simple/t/tbt_07args.t +++ b/lib/Test/Simple/t/Tester/tbt_07args.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/Tester/tbt_07args.t 60331 2008-09-09T12:17:12.607612Z schwern $ use Test::More tests => 18; use Symbol; diff --git a/lib/Test/Simple/t/bad_plan.t b/lib/Test/Simple/t/bad_plan.t index 442fee8..10207b4 100644 --- a/lib/Test/Simple/t/bad_plan.t +++ b/lib/Test/Simple/t/bad_plan.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/bad_plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/bail_out.t b/lib/Test/Simple/t/bail_out.t index d60c150..4af221b 100644 --- a/lib/Test/Simple/t/bail_out.t +++ b/lib/Test/Simple/t/bail_out.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/bail_out.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/buffer.t b/lib/Test/Simple/t/buffer.t index 6039e4a..1fdc930 100644 --- a/lib/Test/Simple/t/buffer.t +++ b/lib/Test/Simple/t/buffer.t @@ -1,4 +1,5 @@ #!/usr/bin/perl +# $Id: /mirror/googlecode/test-more/t/buffer.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/circular_data.t b/lib/Test/Simple/t/circular_data.t index 2fd819e..4f41ae1 100644 --- a/lib/Test/Simple/t/circular_data.t +++ b/lib/Test/Simple/t/circular_data.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/circular_data.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ # Test is_deeply and friends with circular data structures [rt.cpan.org 7289] diff --git a/lib/Test/Simple/t/cmp_ok.t b/lib/Test/Simple/t/cmp_ok.t index b3642ad..38d412d 100644 --- a/lib/Test/Simple/t/cmp_ok.t +++ b/lib/Test/Simple/t/cmp_ok.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/cmp_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/diag.t b/lib/Test/Simple/t/diag.t index b5e5876..567671e 100644 --- a/lib/Test/Simple/t/diag.t +++ b/lib/Test/Simple/t/diag.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/diag.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/died.t b/lib/Test/Simple/t/died.t new file mode 100644 index 0000000..6e4d40c --- /dev/null +++ b/lib/Test/Simple/t/died.t @@ -0,0 +1,46 @@ +#!perl -w +# $Id: /mirror/googlecode/test-more/t/died.t 60310 2008-09-07T23:47:22.837229Z schwern $ + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); +exit 250; + +END { + $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 250, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff --git a/lib/Test/Simple/t/dont_overwrite_die_handler.t b/lib/Test/Simple/t/dont_overwrite_die_handler.t index 0657a06..4c0968f 100644 --- a/lib/Test/Simple/t/dont_overwrite_die_handler.t +++ b/lib/Test/Simple/t/dont_overwrite_die_handler.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/dont_overwrite_die_handler.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/eq_set.t b/lib/Test/Simple/t/eq_set.t index fbdc52d..bd04f78 100644 --- a/lib/Test/Simple/t/eq_set.t +++ b/lib/Test/Simple/t/eq_set.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/eq_set.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index e85e460..fe53cbb 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/exit.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ # Can't use Test.pm, that's a 5.005 thing. package My::Test; @@ -64,13 +65,13 @@ else { *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } } +my $Perl = File::Spec->rel2abs($^X); + chdir 't'; my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); while( my($test_name, $exit_codes) = each %Tests ) { my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0]; - my $Perl = $^X; - if( $^O eq 'VMS' ) { # VMS can't use its own $^X in a system call until almost 5.8 $Perl = "MCR $^X" if $] < 5.007003; diff --git a/lib/Test/Simple/t/explain.t b/lib/Test/Simple/t/explain.t new file mode 100644 index 0000000..f623ef4 --- /dev/null +++ b/lib/Test/Simple/t/explain.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/explain.t 60308 2008-09-07T22:36:18.175234Z schwern $ + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More tests => 5; + +can_ok "main", "explain"; + +is_deeply [explain("foo")], ["foo"]; +is_deeply [explain("foo", "bar")], ["foo", "bar"]; + +# Avoid future dump formatting changes from breaking tests by just eval'ing +# the dump +is_deeply [map { eval $_ } explain([], {})], [[], {}]; + +is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99]; diff --git a/lib/Test/Simple/t/extra.t b/lib/Test/Simple/t/extra.t index 6a0082f..0fcc0ee 100644 --- a/lib/Test/Simple/t/extra.t +++ b/lib/Test/Simple/t/extra.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/extra.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -51,7 +52,7 @@ OUT # at $0 line 31. # Failed test 'Sar' # at $0 line 34. -# Looks like you planned 3 tests but ran 2 extra. +# Looks like you planned 3 tests but ran 5. # Looks like you failed 2 tests of 5 run. ERR diff --git a/lib/Test/Simple/t/extra_one.t b/lib/Test/Simple/t/extra_one.t index 30830d3..211d97b 100644 --- a/lib/Test/Simple/t/extra_one.t +++ b/lib/Test/Simple/t/extra_one.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/extra_one.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -44,7 +45,7 @@ ok 3 OUT My::Test::is($$err, <create; -$TB->plan(tests => 2); +$TB->plan(tests => 4); require Test::Simple::Catch; @@ -43,11 +37,10 @@ package main; require Test::More; Test::More->import(tests => 1); -eval q{ like( "foo", qr/that/, 'is foo like that' ); }; - +{ + eval q{ like( "foo", qr/that/, 'is foo like that' ); }; -END { - $TB->is_eq($$out, <is_eq($out->read, <like($err->read, qr/^$err_re$/, 'failing errors'); +} - $TB->like($$err, qr/^$err_re$/, 'failing errors'); +{ + # line 60 + like("foo", "not a regex"); + $TB->is_eq($out->read, <is_eq($err->read, <summary); } diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t index 23bfd21..95b04b4 100644 --- a/lib/Test/Simple/t/fail-more.t +++ b/lib/Test/Simple/t/fail-more.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/fail-more.t 60310 2008-09-07T23:47:22.837229Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -24,7 +25,7 @@ package My::Test; # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; -$TB->plan(tests => 17); +$TB->plan(tests => 23); sub like ($$;$) { $TB->like(@_); @@ -41,11 +42,18 @@ sub main::err_ok ($) { return $TB->is_eq( $got, $expect ); } +sub main::err_like ($) { + my($expect) = @_; + my $got = $err->read; + + return $TB->like( $got, qr/$expect/ ); +} + package main; require Test::More; -my $Total = 30; +my $Total = 36; Test::More->import(tests => $Total); # This should all work in the presence of a __DIE__ handler. @@ -96,19 +104,16 @@ isnt(undef, undef, 'undef isnt undef?'); err_ok( <= 5.008001 && $Config{'useithreads'} && eval { require threads; 'threads'->import; 1; }) { - print "1..0 # Skip: no working threads\n"; + print "1..0 # Skip no working threads\n"; exit 0; } unless ( $ENV{AUTHOR_TESTING} ) { - print "1..0 # Skip: many perls have broken threads. Enable with AUTHOR_TESTING.\n"; + print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } diff --git a/lib/Test/Simple/t/lib/Dummy.pm b/lib/Test/Simple/t/lib/Dummy.pm index 5e5b439..5eb9157 100644 --- a/lib/Test/Simple/t/lib/Dummy.pm +++ b/lib/Test/Simple/t/lib/Dummy.pm @@ -1,5 +1,6 @@ package Dummy; +# $Id: /mirror/googlecode/test-more/t/lib/Dummy.pm 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ $VERSION = '0.01'; -1; \ No newline at end of file +1; diff --git a/lib/Test/Simple/t/lib/MyOverload.pm b/lib/Test/Simple/t/lib/MyOverload.pm index 91632e9..07b1dbe 100644 --- a/lib/Test/Simple/t/lib/MyOverload.pm +++ b/lib/Test/Simple/t/lib/MyOverload.pm @@ -1,11 +1,11 @@ package Overloaded; +# $Id: /mirror/googlecode/test-more-trunk/t/lib/MyOverload.pm 67132 2008-10-01T01:11:04.501643Z schwern $ sub new { my $class = shift; bless { string => shift, num => shift }, $class; } - package Overloaded::Compare; use vars qw(@ISA); @ISA = qw(Overloaded); @@ -13,17 +13,15 @@ use vars qw(@ISA); # Sometimes objects have only comparison ops overloaded and nothing else. # For example, DateTime objects. use overload - q{eq} => sub { $_[0]->{string} eq $_[1] }, - q{==} => sub { $_[0]->{num} == $_[1] }; - - + q{eq} => sub { $_[0]->{string} eq $_[1] }, + q{==} => sub { $_[0]->{num} == $_[1] }; package Overloaded::Ify; use vars qw(@ISA); @ISA = qw(Overloaded); use overload - q{""} => sub { $_[0]->{string} }, - q{0+} => sub { $_[0]->{num} }; + q{""} => sub { $_[0]->{string} }, + q{0+} => sub { $_[0]->{num} }; -1; \ No newline at end of file +1; diff --git a/lib/Test/Simple/t/lib/NoExporter.pm b/lib/Test/Simple/t/lib/NoExporter.pm index 1ab5b8f..5eb2b3b 100644 --- a/lib/Test/Simple/t/lib/NoExporter.pm +++ b/lib/Test/Simple/t/lib/NoExporter.pm @@ -1,7 +1,9 @@ package NoExporter; +# $Id: /mirror/googlecode/test-more-trunk/t/lib/NoExporter.pm 67132 2008-10-01T01:11:04.501643Z schwern $ $VERSION = 1.02; -sub import { + +sub import { shift; die "NoExporter exports nothing. You asked for: @_" if @_; } diff --git a/lib/Test/Simple/t/missing.t b/lib/Test/Simple/t/missing.t index 7912137..cb46aff 100644 --- a/lib/Test/Simple/t/missing.t +++ b/lib/Test/Simple/t/missing.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/missing.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -33,19 +34,23 @@ Test::Simple->import(tests => 5); #line 30 ok(1, 'Foo'); ok(0, 'Bar'); +ok(1, '1 2 3'); END { My::Test::is($$out, < 13; + +{ + package Bar; + + sub new { + my $class = shift; + return bless {@_}, $class; + } + + + package Foo; + our @ISA = qw(Bar); +} + +{ + my $obj = new_ok("Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; + + $obj = new_ok("Bar"); + is_deeply $obj, {}; + isa_ok $obj, "Bar"; + + $obj = new_ok("Foo", [this => 42]); + is_deeply $obj, { this => 42 }; + isa_ok $obj, "Foo"; + + $obj = new_ok("Foo", [], "Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; +} + +# And what if we give it nothing? +eval { + new_ok(); +}; +is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; diff --git a/lib/Test/Simple/t/no_plan.t b/lib/Test/Simple/t/no_plan.t index 6eecd43..a97f65f 100644 --- a/lib/Test/Simple/t/no_plan.t +++ b/lib/Test/Simple/t/no_plan.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/no_plan.t 60319 2008-09-08T21:16:57.125001Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -10,7 +11,7 @@ BEGIN { } } -use Test::More tests => 6; +use Test::More tests => 9; my $tb = Test::Builder->create; $tb->level(0); @@ -23,6 +24,16 @@ is($@, "Got an undefined number of tests at $0 line 19.\n"); ok !eval { $tb->plan(tests => 0) }; is($@, "You said to run 0 tests at $0 line 23.\n"); -#line 27 +#line 28 ok !eval { $tb->ok(1) }; -is( $@, "You tried to run a test without a plan at $0 line 27.\n"); +is( $@, "You tried to run a test without a plan at $0 line 28.\n"); + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= join '', @_ }; + +#line 36 + ok $tb->plan(no_plan => 1); + is( $warning, "no_plan takes no arguments at $0 line 36.\n" ); + is $tb->has_plan, 'no_plan'; +} diff --git a/lib/Test/Simple/t/no_tests.t b/lib/Test/Simple/t/no_tests.t new file mode 100644 index 0000000..5e6e86b --- /dev/null +++ b/lib/Test/Simple/t/no_tests.t @@ -0,0 +1,45 @@ +#!perl -w +# $Id: /mirror/googlecode/test-more/t/no_tests.t 60310 2008-09-07T23:47:22.837229Z schwern $ + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); + +END { + $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 255, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff --git a/lib/Test/Simple/t/note.t b/lib/Test/Simple/t/note.t new file mode 100644 index 0000000..2a72b5d --- /dev/null +++ b/lib/Test/Simple/t/note.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/note.t 60308 2008-09-07T22:36:18.175234Z schwern $ + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use TieOut; + +use Test::More tests => 2; + +{ + my $test = Test::More->builder; + + my $output = tie *FAKEOUT, "TieOut"; + my $fail_output = tie *FAKEERR, "TieOut"; + $test->output (*FAKEOUT); + $test->failure_output(*FAKEERR); + + note("foo"); + + $test->reset_outputs; + + is $output->read, "# foo\n"; + is $fail_output->read, ''; +} + diff --git a/lib/Test/Simple/t/overload.t b/lib/Test/Simple/t/overload.t index d5e4c10..0ac5f0e 100644 --- a/lib/Test/Simple/t/overload.t +++ b/lib/Test/Simple/t/overload.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/overload.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/overload_threads.t b/lib/Test/Simple/t/overload_threads.t index 8ba78c1..d02c504 100644 --- a/lib/Test/Simple/t/overload_threads.t +++ b/lib/Test/Simple/t/overload_threads.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/overload_threads.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/plan.t b/lib/Test/Simple/t/plan.t index 0d3ce89..7ccca6d 100644 --- a/lib/Test/Simple/t/plan.t +++ b/lib/Test/Simple/t/plan.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/plan_bad.t b/lib/Test/Simple/t/plan_bad.t index d20797e..c93c214 100644 --- a/lib/Test/Simple/t/plan_bad.t +++ b/lib/Test/Simple/t/plan_bad.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/plan_bad.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -8,7 +9,7 @@ BEGIN { } -use Test::More tests => 10; +use Test::More tests => 12; use Test::Builder; my $tb = Test::Builder->create; $tb->level(0); @@ -21,6 +22,9 @@ my @foo = ($foo, 2, 3); ok !eval { $tb->plan( tests => @foo ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1; +ok !eval { $tb->plan( tests => 9.99 ) }; +is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1; + #line 25 ok !eval { $tb->plan( tests => -1 ) }; is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n"; diff --git a/lib/Test/Simple/t/plan_is_noplan.t b/lib/Test/Simple/t/plan_is_noplan.t index e39cd40..d11c437 100644 --- a/lib/Test/Simple/t/plan_is_noplan.t +++ b/lib/Test/Simple/t/plan_is_noplan.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/plan_is_noplan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/plan_no_plan.t b/lib/Test/Simple/t/plan_no_plan.t index 3111592..2935b1b 100644 --- a/lib/Test/Simple/t/plan_no_plan.t +++ b/lib/Test/Simple/t/plan_no_plan.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/plan_no_plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/plan_shouldnt_import.t b/lib/Test/Simple/t/plan_shouldnt_import.t index b6eb064..bd320fa 100644 --- a/lib/Test/Simple/t/plan_shouldnt_import.t +++ b/lib/Test/Simple/t/plan_shouldnt_import.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/plan_shouldnt_import.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ # plan() used to export functions by mistake [rt.cpan.org 8385] diff --git a/lib/Test/Simple/t/plan_skip_all.t b/lib/Test/Simple/t/plan_skip_all.t index 528df5f..99ce9d7 100644 --- a/lib/Test/Simple/t/plan_skip_all.t +++ b/lib/Test/Simple/t/plan_skip_all.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/plan_skip_all.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/require_ok.t b/lib/Test/Simple/t/require_ok.t index 463a007..6d0bfd0 100644 --- a/lib/Test/Simple/t/require_ok.t +++ b/lib/Test/Simple/t/require_ok.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/require_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/simple.t b/lib/Test/Simple/t/simple.t index 7297e9d..276924c 100644 --- a/lib/Test/Simple/t/simple.t +++ b/lib/Test/Simple/t/simple.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/simple.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/skip.t b/lib/Test/Simple/t/skip.t index b7ec32a..e199b11 100644 --- a/lib/Test/Simple/t/skip.t +++ b/lib/Test/Simple/t/skip.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more/t/skip.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/skipall.t b/lib/Test/Simple/t/skipall.t index 6f255e2..b0c476b 100644 --- a/lib/Test/Simple/t/skipall.t +++ b/lib/Test/Simple/t/skipall.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/skipall.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t b/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t index f5ad001..4908a3c 100644 --- a/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t +++ b/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/tbm_doesnt_set_exported_to.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -21,4 +22,4 @@ $TB->level(0); $TB->is_eq( Test::Builder::Module->builder->exported_to, undef, 'using Test::Builder::Module does not set exported_to()' -); \ No newline at end of file +); diff --git a/lib/Test/Simple/t/tbt_04line_num.t b/lib/Test/Simple/t/tbt_04line_num.t deleted file mode 100644 index 9e8365a..0000000 --- a/lib/Test/Simple/t/tbt_04line_num.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/perl - -use Test::More tests => 3; -use Test::Builder::Tester; - -is(line_num(),6,"normal line num"); -is(line_num(-1),6,"line number minus one"); -is(line_num(+2),10,"line number plus two"); diff --git a/lib/Test/Simple/t/thread_taint.t b/lib/Test/Simple/t/thread_taint.t index d547e6d..f3b8ad8 100644 --- a/lib/Test/Simple/t/thread_taint.t +++ b/lib/Test/Simple/t/thread_taint.t @@ -1,5 +1,6 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/thread_taint.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ use Test::More tests => 1; -ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); \ No newline at end of file +ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); diff --git a/lib/Test/Simple/t/threads.t b/lib/Test/Simple/t/threads.t index 42ba8c2..1daec94 100644 --- a/lib/Test/Simple/t/threads.t +++ b/lib/Test/Simple/t/threads.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/threads.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Simple/t/todo.t b/lib/Test/Simple/t/todo.t index d589c92..8a30ad1 100644 --- a/lib/Test/Simple/t/todo.t +++ b/lib/Test/Simple/t/todo.t @@ -1,4 +1,5 @@ #!perl -w +# $Id: /mirror/googlecode/test-more-trunk/t/todo.t 62094 2008-09-19T07:21:50.720642Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -9,7 +10,7 @@ BEGIN { use Test::More; -plan tests => 19; +plan tests => 36; $Why = 'Just testing the todo interface.'; @@ -69,20 +70,89 @@ TODO: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; -#line 73 +#line 74 todo_skip "Just testing todo_skip"; fail("So very failed"); } is( $warning, "todo_skip() needs to know \$how_many tests are in the ". - "block at $0 line 73\n", + "block at $0 line 74\n", 'todo_skip without $how_many warning' ); } - +my $builder = Test::More->builder; +my $exported_to = $builder->exported_to; TODO: { - Test::More->builder->exported_to("Wibble"); + $builder->exported_to("Wibble"); local $TODO = "testing \$TODO with an incorrect exported_to()"; fail("Just testing todo"); } + +$builder->exported_to($exported_to); + +$builder->todo_start('Expected failures'); +fail('Testing todo_start()'); +ok 0, 'Testing todo_start() with more than one failure'; +$is_todo = $builder->todo; +$builder->todo_end; +is $is_todo, 'Expected failures', + 'todo_start should have the correct TODO message'; +ok 1, 'todo_end() should not leak TODO behavior'; + +my @nested_todo; +my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' ); +TODO: { + local $TODO = 'Nesting TODO'; + fail('fail 1'); + + $builder->todo_start($level1); + fail('fail 2'); + + push @nested_todo => $builder->todo; + $builder->todo_start($level2); + fail('fail 3'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + fail('fail 4'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + $is_todo = $builder->todo; + fail('fail 4'); +} +is_deeply \@nested_todo, [ $level1, $level2, $level1 ], + 'Nested TODO message should be correct'; +is $is_todo, 'Nesting TODO', + '... and original TODO message should be correct'; + +{ + $builder->todo_start; + fail("testing todo_start() with no message"); + my $reason = $builder->todo; + my $in_todo = $builder->in_todo; + $builder->todo_end; + + is $reason, '', " todo() reports no reason"; + ok $in_todo, " but we're in_todo()"; +} + +eval { + $builder->todo_end; +}; +is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2; + + +{ + my($reason, $in_todo); + + TODO: { + local $TODO = ''; + $reason = $builder->todo; + $in_todo = $builder->in_todo; + } + + is $reason, ''; + ok !$in_todo, '$TODO = "" is not considered TODO'; +} diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index 7afb2a6..93c77bd 100644 --- a/lib/Test/Simple/t/undef.t +++ b/lib/Test/Simple/t/undef.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/undef.t 60310 2008-09-07T23:47:22.837229Z schwern $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -11,7 +12,7 @@ BEGIN { } use strict; -use Test::More tests => 18; +use Test::More tests => 20; use TieOut; BEGIN { $^W = 1; } @@ -48,6 +49,9 @@ no_warnings; isnt( undef, '', 'undef isnt an empty string' ); isnt( undef, 0, 'undef isnt zero' ); +Test::More->builder->is_num(undef, undef, 'is_num()'); +Test::More->builder->isnt_num(23, undef, 'isnt_num()'); + #line 45 like( undef, '/.*/', 'undef is like anything' ); warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n"); diff --git a/lib/Test/Simple/t/use_ok.t b/lib/Test/Simple/t/use_ok.t index b618acc..9781ac8 100644 --- a/lib/Test/Simple/t/use_ok.t +++ b/lib/Test/Simple/t/use_ok.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/use_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { @@ -10,7 +11,7 @@ BEGIN { } } -use Test::More tests => 13; +use Test::More tests => 15; # Using Symbol because it's core and exports lots of stuff. { @@ -58,3 +59,10 @@ use Test::More tests => 13; }; ::use_ok("Test::More", 0.47); } + +{ + package Foo::eight; + local $SIG{__DIE__}; + ::use_ok("SigDie"); + ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); +} diff --git a/lib/Test/Simple/t/useing.t b/lib/Test/Simple/t/useing.t index c4ce507..f67ecd8 100644 --- a/lib/Test/Simple/t/useing.t +++ b/lib/Test/Simple/t/useing.t @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/t/useing.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/lib/Test/Simple/t/utf8.t b/lib/Test/Simple/t/utf8.t index c7e93c3..544ad1c 100644 --- a/lib/Test/Simple/t/utf8.t +++ b/lib/Test/Simple/t/utf8.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# $Id: /mirror/googlecode/test-more/t/utf8.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/lib/Test/Tutorial.pod b/lib/Test/Tutorial.pod index b730918..4de4a90 100644 --- a/lib/Test/Tutorial.pod +++ b/lib/Test/Tutorial.pod @@ -1,3 +1,4 @@ +# $Id: /mirror/googlecode/test-more/lib/Test/Tutorial.pod 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ =head1 NAME Test::Tutorial - A tutorial about writing really basic tests -- 2.7.4