From cc7a7619c1d992b56bedb906773909696126cdc9 Mon Sep 17 00:00:00 2001 From: mertz Date: Mon, 22 Sep 2003 10:11:39 +0000 Subject: these files are used for building complexe test files --- Perl/t/Test/Builder.pm | 1408 +++++++++++++++++++++++++++++++++++++++ Perl/t/Test/Harness.pm | 1168 ++++++++++++++++++++++++++++++++ Perl/t/Test/Harness/Assert.pm | 68 ++ Perl/t/Test/Harness/Iterator.pm | 61 ++ Perl/t/Test/Harness/Straps.pm | 667 +++++++++++++++++++ Perl/t/Test/More.pm | 1248 ++++++++++++++++++++++++++++++++++ 6 files changed, 4620 insertions(+) create mode 100644 Perl/t/Test/Builder.pm create mode 100644 Perl/t/Test/Harness.pm create mode 100644 Perl/t/Test/Harness/Assert.pm create mode 100644 Perl/t/Test/Harness/Iterator.pm create mode 100644 Perl/t/Test/Harness/Straps.pm create mode 100644 Perl/t/Test/More.pm (limited to 'Perl/t') diff --git a/Perl/t/Test/Builder.pm b/Perl/t/Test/Builder.pm new file mode 100644 index 0000000..6f3edd8 --- /dev/null +++ b/Perl/t/Test/Builder.pm @@ -0,0 +1,1408 @@ +package Test::Builder; + +use 5.004; + +# $^C was only introduced in 5.005-ish. We do this to prevent +# use of uninitialized value warnings in older perls. +$^C ||= 0; + +use strict; +use vars qw($VERSION $CLASS); +$VERSION = '0.17'; +$CLASS = __PACKAGE__; + +my $IsVMS = $^O eq 'VMS'; + +# Make Test::Builder thread-safe for ithreads. +BEGIN { + use Config; + if( $] >= 5.008 && $Config{useithreads} ) { + require threads; + require threads::shared; + threads::shared->import; + } + else { + *share = sub { 0 }; + *lock = sub { 0 }; + } +} + +use vars qw($Level); +my($Test_Died) = 0; +my($Have_Plan) = 0; +my $Original_Pid = $$; +my $Curr_Test = 0; share($Curr_Test); +my @Test_Results = (); share(@Test_Results); +my @Test_Details = (); share(@Test_Details); + + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use Test::Builder; + require Exporter; + @ISA = qw(Exporter); + @EXPORT = qw(ok); + + my $Test = Test::Builder->new; + $Test->output('my_logfile'); + + sub import { + my($self) = shift; + my $pack = caller; + + $Test->exported_to($pack); + $Test->plan(@_); + + $self->export_to_level(1, $self, 'ok'); + } + + sub ok { + my($test, $name) = @_; + + $Test->ok($test, $name); + } + + +=head1 DESCRIPTION + +Test::Simple and Test::More have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides the a +building block upon which to write your own test libraries I. + +=head2 Construction + +=over 4 + +=item B + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program, there is B +Test::Builder object. No matter how many times you call new(), you're +getting the same object. (This is called a singleton). + +=cut + +my $Test; +sub new { + my($class) = shift; + $Test ||= bless ['Move along, nothing to see here'], $class; + return $Test; +} + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. +This is important for getting TODO tests right. + +=cut + +my $Exported_To; +sub exported_to { + my($self, $pack) = @_; + + if( defined $pack ) { + $Exported_To = $pack; + } + return $Exported_To; +} + +=item B + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call plan(), don't call any of the other methods below. + +=cut + +sub plan { + my($self, $cmd, $arg) = @_; + + return unless $cmd; + + if( $Have_Plan ) { + die sprintf "You tried to plan twice! Second plan at %s line %d\n", + ($self->caller)[1,2]; + } + + if( $cmd eq 'no_plan' ) { + $self->no_plan; + } + elsif( $cmd eq 'skip_all' ) { + return $self->skip_all($arg); + } + elsif( $cmd eq 'tests' ) { + if( $arg ) { + return $self->expected_tests($arg); + } + elsif( !defined $arg ) { + die "Got an undefined number of tests. Looks like you tried to ". + "say how many tests you plan to run but made a mistake.\n"; + } + elsif( !$arg ) { + die "You said to run 0 tests! You've got to run something.\n"; + } + } + else { + require Carp; + my @args = grep { defined } ($cmd, $arg); + Carp::croak("plan() doesn't understand @args"); + } + + return 1; +} + +=item B + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the # of tests we expect this test to run and prints out +the appropriate headers. + +=cut + +my $Expected_Tests = 0; +sub expected_tests { + my($self, $max) = @_; + + if( defined $max ) { + $Expected_Tests = $max; + $Have_Plan = 1; + + $self->_print("1..$max\n") unless $self->no_header; + } + return $Expected_Tests; +} + + +=item B + + $Test->no_plan; + +Declares that this test will run an indeterminate # of tests. + +=cut + +my($No_Plan) = 0; +sub no_plan { + $No_Plan = 1; + $Have_Plan = 1; +} + +=item B + + $plan = $Test->has_plan + +Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). + +=cut + +sub has_plan { + return($Expected_Tests) if $Expected_Tests; + return('no_plan') if $No_Plan; + return(undef); +}; + + +=item B + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given $reason. Exits immediately with 0. + +=cut + +my $Skip_All = 0; +sub skip_all { + my($self, $reason) = @_; + + my $out = "1..0"; + $out .= " # Skip $reason" if $reason; + $out .= "\n"; + + $Skip_All = 1; + + $self->_print($out) unless $self->no_header; + exit(0); +} + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in +Test::More. + +$name is always optional. + +=over 4 + +=item B + + $Test->ok($test, $name); + +Your basic test. Pass if $test is true, fail if $test is false. Just +like Test::Simple's ok(). + +=cut + +sub ok { + my($self, $test, $name) = @_; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run a test without a plan! Gotta have a plan."); + } + + lock $Curr_Test; + $Curr_Test++; + + $self->diag(<caller; + + my $todo = $self->todo($pack); + + my $out; + my $result = {}; + share($result); + + unless( $test ) { + $out .= "not "; + @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } + + $out .= "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if( $todo ) { + my $what_todo = $todo; + $out .= " # TODO $what_todo"; + $result->{reason} = $what_todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $Test_Results[$Curr_Test-1] = $result; + $out .= "\n"; + + $self->_print($out); + + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $self->diag(" $msg test ($file at line $line)\n"); + } + + return $test ? 1 : 0; +} + +=item B + + $Test->is_eq($got, $expected, $name); + +Like Test::More's is(). Checks if $got eq $expected. This is the +string version. + +=item B + + $Test->is_num($got, $expected, $name); + +Like Test::More's is(). Checks if $got == $expected. This is the +numeric version. + +=cut + +sub is_eq { + my($self, $got, $expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok($test, $name); + $self->_is_diag($got, 'eq', $expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, 'eq', $expect, $name); +} + +sub is_num { + my($self, $got, $expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok($test, $name); + $self->_is_diag($got, '==', $expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, '==', $expect, $name); +} + +sub _is_diag { + my($self, $got, $type, $expect) = @_; + + foreach my $val (\$got, \$expect) { + if( defined $$val ) { + if( $type eq 'eq' ) { + # quote and force string context + $$val = "'$$val'" + } + else { + # force numeric context + $$val = $$val+0; + } + } + else { + $$val = 'undef'; + } + } + + return $self->diag(sprintf < + + $Test->isnt_eq($got, $dont_expect, $name); + +Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +the string version. + +=item B + + $Test->is_num($got, $dont_expect, $name); + +Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +the numeric version. + +=cut + +sub isnt_eq { + my($self, $got, $dont_expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok($test, $name); + $self->_cmp_diag('ne', $got, $dont_expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, 'ne', $dont_expect, $name); +} + +sub isnt_num { + my($self, $got, $dont_expect, $name) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok($test, $name); + $self->_cmp_diag('!=', $got, $dont_expect) unless $test; + return $test; + } + + return $self->cmp_ok($got, '!=', $dont_expect, $name); +} + + +=item B + + $Test->like($this, qr/$regex/, $name); + $Test->like($this, '/$regex/', $name); + +Like Test::More's like(). Checks if $this matches the given $regex. + +You'll want to avoid qr// if you want your tests to work before 5.005. + +=item B + + $Test->unlike($this, qr/$regex/, $name); + $Test->unlike($this, '/$regex/', $name); + +Like Test::More's unlike(). Checks if $this B the +given $regex. + +=cut + +sub like { + my($self, $this, $regex, $name) = @_; + + local $Level = $Level + 1; + $self->_regex_ok($this, $regex, '=~', $name); +} + +sub unlike { + my($self, $this, $regex, $name) = @_; + + local $Level = $Level + 1; + $self->_regex_ok($this, $regex, '!~', $name); +} + +=item B + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +Convenience method for building testing functions that take regular +expressions as arguments, but need to work before perl 5.005. + +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. + +For example, a version of like(), sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ m/$usable_regex/, $name); + } + +=cut + + +sub maybe_regex { + my ($self, $regex) = @_; + my $usable_regex = undef; + if( ref $regex eq 'Regexp' ) { + $usable_regex = $regex; + } + # Check if it looks like '/foo/' + elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { + $usable_regex = length $opts ? "(?$opts)$re" : $re; + }; + return($usable_regex) +}; + +sub _regex_ok { + my($self, $this, $regex, $cmp, $name) = @_; + + local $Level = $Level + 1; + + my $ok = 0; + my $usable_regex = $self->maybe_regex($regex); + unless (defined $usable_regex) { + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); + return $ok; + } + + { + local $^W = 0; + my $test = $this =~ /$usable_regex/ ? 1 : 0; + $test = !$test if $cmp eq '!~'; + $ok = $self->ok( $test, $name ); + } + + unless( $ok ) { + $this = defined $this ? "'$this'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + $self->diag(sprintf < + + $Test->cmp_ok($this, $type, $that, $name); + +Works just like Test::More's cmp_ok(). + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=cut + +sub cmp_ok { + my($self, $got, $type, $expect, $name) = @_; + + my $test; + { + local $^W = 0; + local($@,$!); # don't interfere with $@ + # eval() sometimes resets $! + $test = eval "\$got $type \$expect"; + } + local $Level = $Level + 1; + my $ok = $self->ok($test, $name); + + unless( $ok ) { + if( $type =~ /^(eq|==)$/ ) { + $self->_is_diag($got, $type, $expect); + } + else { + $self->_cmp_diag($got, $type, $expect); + } + } + return $ok; +} + +sub _cmp_diag { + my($self, $got, $type, $expect) = @_; + + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + return $self->diag(sprintf < + + $Test->BAILOUT($reason); + +Indicates to the Test::Harness that things are going so badly all +testing should terminate. This includes running any additional test +scripts. + +It will exit with 255. + +=cut + +sub BAILOUT { + my($self, $reason) = @_; + + $self->_print("Bail out! $reason"); + exit 255; +} + +=item B + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting $why. + +=cut + +sub skip { + my($self, $why) = @_; + $why ||= ''; + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); + } + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + ); + $Test_Results[$Curr_Test-1] = \%result; + + my $out = "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + $out .= " # skip $why\n"; + + $Test->_print($out); + + return 1; +} + + +=item B + + $Test->todo_skip; + $Test->todo_skip($why); + +Like skip(), only it will declare the test as failing and TODO. Similar +to + + print "not ok $tnum # TODO $why\n"; + +=cut + +sub todo_skip { + my($self, $why) = @_; + $why ||= ''; + + unless( $Have_Plan ) { + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); + } + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + ); + + $Test_Results[$Curr_Test-1] = \%result; + + my $out = "not ok"; + $out .= " $Curr_Test" if $self->use_numbers; + $out .= " # TODO & SKIP $why\n"; + + $Test->_print($out); + + return 1; +} + + +=begin _unimplemented + +=item B + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like skip(), only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under no_plan, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test style + +=over 4 + +=item B + + $Test->level($how_high); + +How far up the call stack should $Test look when reporting where the +test failed. + +Defaults to 1. + +Setting $Test::Builder::Level overrides. This is typically useful +localized: + + { + local $Test::Builder::Level = 2; + $Test->ok($test); + } + +=cut + +sub level { + my($self, $level) = @_; + + if( defined $level ) { + $Level = $level; + } + return $Level; +} + +$CLASS->level(1); + + +=item B + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Test::Harness will accept either, but avoid mixing the two styles. + +Defaults to on. + +=cut + +my $Use_Nums = 1; +sub use_numbers { + my($self, $use_nums) = @_; + + if( defined $use_nums ) { + $Use_Nums = $use_nums; + } + return $Use_Nums; +} + +=item B + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=item B + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described in Test::Simple. + +If this is true, none of that will be done. + +=cut + +my($No_Header, $No_Ending) = (0,0); +sub no_header { + my($self, $no_header) = @_; + + if( defined $no_header ) { + $No_Header = $no_header; + } + return $No_Header; +} + +sub no_ending { + my($self, $no_ending) = @_; + + if( defined $no_ending ) { + $No_Ending = $no_ending; + } + return $No_Ending; +} + + +=back + +=head2 Output + +Controlling where the test output goes. + +It's ok for your test to change where STDOUT and STDERR point to, +Test::Builder's default output settings will not be affected. + +=over 4 + +=item B + + $Test->diag(@msgs); + +Prints out the given $message. Normally, it uses the failure_output() +handle, but if this is for a TODO test, the todo_output() handle is +used. + +Output will be indented and marked with a # so as not to interfere +with test output. A newline will be put on the end if there isn't one +already. + +We encourage using this rather than calling print directly. + +Returns false. Why? Because diag() is often used in conjunction with +a failing test (C) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler + +=cut + +sub diag { + my($self, @msgs) = @_; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + # Escape each line with a #. + foreach (@msgs) { + $_ = 'undef' unless defined; + s/^/# /gms; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + + local $Level = $Level + 1; + my $fh = $self->todo ? $self->todo_output : $self->failure_output; + local($\, $", $,) = (undef, ' ', ''); + print $fh @msgs; + + return 0; +} + +=begin _private + +=item B<_print> + + $Test->_print(@msgs); + +Prints to the output() filehandle. + +=end _private + +=cut + +sub _print { + my($self, @msgs) = @_; + + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; + + local($\, $", $,) = (undef, ' ', ''); + my $fh = $self->output; + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + foreach (@msgs) { + s/\n(.)/\n# $1/sg; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + + print $fh @msgs; +} + + +=item B + + $Test->output($fh); + $Test->output($file); + +Where normal "ok/not ok" test output should go. + +Defaults to STDOUT. + +=item B + + $Test->failure_output($fh); + $Test->failure_output($file); + +Where diagnostic output on test failures and diag() should go. + +Defaults to STDERR. + +=item B + + $Test->todo_output($fh); + $Test->todo_output($file); + +Where diagnostics about todo test failures and diag() should go. + +Defaults to STDOUT. + +=cut + +my($Out_FH, $Fail_FH, $Todo_FH); +sub output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Out_FH = _new_fh($fh); + } + return $Out_FH; +} + +sub failure_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Fail_FH = _new_fh($fh); + } + return $Fail_FH; +} + +sub todo_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Todo_FH = _new_fh($fh); + } + return $Todo_FH; +} + +sub _new_fh { + my($file_or_fh) = shift; + + my $fh; + unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { + $fh = do { local *FH }; + open $fh, ">$file_or_fh" or + die "Can't open test output log $file_or_fh: $!"; + } + else { + $fh = $file_or_fh; + } + + return $fh; +} + +unless( $^C ) { + # 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: $!"; + + # Set everything to unbuffered else plain prints to STDOUT will + # come out in the wrong order from our own prints. + _autoflush(\*TESTOUT); + _autoflush(\*STDOUT); + _autoflush(\*TESTERR); + _autoflush(\*STDERR); + + $CLASS->output(\*TESTOUT); + $CLASS->failure_output(\*TESTERR); + $CLASS->todo_output(\*TESTOUT); +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test # we're on. + +You usually shouldn't have to set this. + +=cut + +sub current_test { + my($self, $num) = @_; + + lock($Curr_Test); + if( defined $num ) { + unless( $Have_Plan ) { + require Carp; + Carp::croak("Can't change the current test number without a plan!"); + } + + $Curr_Test = $num; + if( $num > @Test_Results ) { + my $start = @Test_Results ? $#Test_Results + 1 : 0; + for ($start..$num-1) { + my %result; + share(%result); + %result = ( ok => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + ); + $Test_Results[$_] = \%result; + } + } + } + return $Curr_Test; +} + + +=item B + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + +=cut + +sub summary { + my($self) = shift; + + return map { $_->{'ok'} } @Test_Results; +} + +=item B
+ + my @tests = $Test->details; + +Like summary(), but with a lot more detail. + + $tests[$test_num - 1] = + { 'ok' => is the test considered a pass? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => type of test (if any, see below). + reason => reason for the above (if any) + }; + +'ok' is true if Test::Harness will consider the test to be a pass. + +'actual_ok' is a reflection of whether or not the test literally +printed 'ok' or 'not ok'. This is for examining the result of 'todo' +tests. + +'name' is the name of the test. + +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: + + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below + +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when 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. +They are considered ok, but the name and actual_ok is left undef. + +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: + + $tests[22] = # 23 - 1, since arrays start from 0. + { ok => 1, # logically, the test passed since it's todo + actual_ok => 0, # in absolute terms, it failed + name => 'hole count', + type => 'todo', + reason => 'insufficient donuts' + }; + +=cut + +sub details { + return @Test_Results; +} + +=item B + + 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. + +todo() is pretty part about finding the right package to look for +$TODO in. It uses the exported_to() package to find it. If that's +not set, it's pretty good at guessing the right package to look at. + +Sometimes there is some confusion about where todo() should be looking +for the $TODO variable. If you want to be sure, tell it explicitly +what $pack to use. + +=cut + +sub todo { + my($self, $pack) = @_; + + $pack = $pack || $self->exported_to || $self->caller(1); + + no strict 'refs'; + return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} + : 0; +} + +=item B + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal caller(), except it reports according to your level(). + +=cut + +sub caller { + my($self, $height) = @_; + $height ||= 0; + + my @caller = CORE::caller($self->level + $height + 1); + return wantarray ? @caller : $caller[0]; +} + +=back + +=cut + +=begin _private + +=over 4 + +=item B<_sanity_check> + + _sanity_check(); + +Runs a bunch of end of test sanity checks to make sure reality came +through ok. If anything is wrong it will die with a fairly friendly +error message. + +=cut + +#'# +sub _sanity_check { + _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); + _whoa(!$Have_Plan and $Curr_Test, + 'Somehow your tests ran without a plan!'); + _whoa($Curr_Test != @Test_Results, + 'Somehow you got a different number of results than tests ran!'); +} + +=item B<_whoa> + + _whoa($check, $description); + +A sanity check, similar to assert(). If the $check is true, something +has gone horribly wrong. It will die with the given $description and +a note to contact the author. + +=cut + +sub _whoa { + my($check, $desc) = @_; + if( $check ) { + die < + + _my_exit($exit_num); + +Perl seems to have some trouble with exiting inside an END block. 5.005_03 +and 5.6.1 both seem to do odd things. Instead, this function edits $? +directly. It should ONLY be called from inside an END block. It +doesn't actually exit, that's your job. + +=cut + +sub _my_exit { + $? = $_[0]; + + return 1; +} + + +=back + +=end _private + +=cut + +$SIG{__DIE__} = sub { + # We don't want to muck with death in an eval, but $^S isn't + # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing + # with it. Instead, we use caller. This also means it runs under + # 5.004! + my $in_eval = 0; + for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { + $in_eval = 1 if $sub =~ /^\(eval\)/; + } + $Test_Died = 1 unless $in_eval; +}; + +sub _ending { + my $self = shift; + + _sanity_check(); + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + do{ _my_exit($?) && return } if $Original_Pid != $$; + + # Bailout if plan() was never called. This is so + # "require Test::Simple" doesn't puke. + do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; + + # Figure out if we passed or failed and print helpful messages. + if( @Test_Results ) { + # The plan? We have no plan. + if( $No_Plan ) { + $self->_print("1..$Curr_Test\n") unless $self->no_header; + $Expected_Tests = $Curr_Test; + } + + # 5.8.0 threads bug. Shared arrays will not be auto-extended + # by a slice. Worse, we have to fill in every entry else + # we'll get an "Invalid value for shared scalar" error + for my $idx ($#Test_Results..$Expected_Tests-1) { + my %empty_result = (); + share(%empty_result); + $Test_Results[$idx] = \%empty_result + unless defined $Test_Results[$idx]; + } + + my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; + $num_failed += abs($Expected_Tests - @Test_Results); + + if( $Curr_Test < $Expected_Tests ) { + $self->diag(<<"FAIL"); +Looks like you planned $Expected_Tests tests but only ran $Curr_Test. +FAIL + } + elsif( $Curr_Test > $Expected_Tests ) { + my $num_extra = $Curr_Test - $Expected_Tests; + $self->diag(<<"FAIL"); +Looks like you planned $Expected_Tests tests but ran $num_extra extra. +FAIL + } + elsif ( $num_failed ) { + $self->diag(<<"FAIL"); +Looks like you failed $num_failed tests of $Expected_Tests. +FAIL + } + + if( $Test_Died ) { + $self->diag(<<"FAIL"); +Looks like your test died just after $Curr_Test. +FAIL + + _my_exit( 255 ) && return; + } + + _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; + } + elsif ( $Skip_All ) { + _my_exit( 0 ) && return; + } + elsif ( $Test_Died ) { + $self->diag(<<'FAIL'); +Looks like your test died before it could output anything. +FAIL + } + else { + $self->diag("No tests run!\n"); + _my_exit( 255 ) && return; + } +} + +END { + $Test->_ending if defined $Test and !$Test->no_ending; +} + +=head1 THREADS + +In perl 5.8.0 and later, Test::Builder is thread-safe. The test +number is shared amongst all threads. This means if one thread sets +the test number using current_test() they will all be effected. + +=head1 EXAMPLES + +CPAN can provide the best examples. Test::Simple, Test::More, +Test::Exception and Test::Differences all use Test::Builder. + +=head1 SEE ALSO + +Test::Simple, Test::More, Test::Harness + +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +Eschwern@pobox.comE + +=head1 COPYRIGHT + +Copyright 2002 by chromatic Echromatic@wgz.orgE, + Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; diff --git a/Perl/t/Test/Harness.pm b/Perl/t/Test/Harness.pm new file mode 100644 index 0000000..0897455 --- /dev/null +++ b/Perl/t/Test/Harness.pm @@ -0,0 +1,1168 @@ +# -*- Mode: cperl; cperl-indent-level: 4 -*- +# $Id$ + +package Test::Harness; + +require 5.004; +use Test::Harness::Straps; +use Test::Harness::Assert; +use Exporter; +use Benchmark; +use Config; +use strict; + +use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest + $Columns $verbose $switches $ML $Strap + @ISA @EXPORT @EXPORT_OK $Last_ML_Print + ); + +# Backwards compatibility for exportable variable names. +*verbose = *Verbose; +*switches = *Switches; + +$Have_Devel_Corestack = 0; + +$VERSION = '2.30'; + +$ENV{HARNESS_ACTIVE} = 1; + +END { + # For VMS. + delete $ENV{HARNESS_ACTIVE}; +} + +# Some experimental versions of OS/2 build have broken $? +my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; + +my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; + +my $Ok_Slow = $ENV{HARNESS_OK_SLOW}; + +$Strap = Test::Harness::Straps->new; + +@ISA = ('Exporter'); +@EXPORT = qw(&runtests); +@EXPORT_OK = qw($verbose $switches); + +$Verbose = $ENV{HARNESS_VERBOSE} || 0; +$Switches = "-w"; +$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; +$Columns--; # Some shells have trouble with a full line of text. + + +=head1 NAME + +Test::Harness - run perl standard test scripts with statistics + +=head1 SYNOPSIS + + use Test::Harness; + + runtests(@test_files); + +=head1 DESCRIPTION + +B If all you want to do is write a test script, consider using +Test::Simple. Otherwise, read on. + +(By using the Test module, you can write test scripts without +knowing the exact output this module expects. However, if you need to +know the specifics, read on!) + +Perl test scripts print to standard output C<"ok N"> for each single +test, where C is an increasing sequence of integers. The first line +output by a standard test script is C<"1..M"> with C being the +number of tests that should be run within the test +script. Test::Harness::runtests(@tests) runs all the testscripts +named as arguments and checks standard output for the expected +C<"ok N"> strings. + +After all tests have been performed, runtests() prints some +performance statistics that are computed by the Benchmark module. + +=head2 The test script output + +The following explains how Test::Harness interprets the output of your +test program. + +=over 4 + +=item B<'1..M'> + +This header tells how many tests there will be. For example, C<1..10> +means you plan on running 10 tests. This is a safeguard in case your +test dies quietly in the middle of its run. + +It should be the first non-comment line output by your test program. + +In certain instances, you may not know how many tests you will +ultimately be running. In this case, it is permitted for the 1..M +header to appear as the B line output by your test (again, it +can be followed by further comments). + +Under B circumstances should 1..M appear in the middle of your +output or more than once. + + +=item B<'ok', 'not ok'. Ok?> + +Any output from the testscript to standard error is ignored and +bypassed, thus will be seen by the user. Lines written to standard +output containing C are interpreted as feedback for +runtests(). All other lines are discarded. + +C indicates a failed test. C is a successful test. + + +=item B + +Perl normally expects the 'ok' or 'not ok' to be followed by a test +number. It is tolerated if the test numbers after 'ok' are +omitted. In this case Test::Harness maintains temporarily its own +counter until the script supplies test numbers again. So the following +test script + + print < + +Anything after the test number but before the # is considered to be +the name of the test. + + ok 42 this is the name of the test + +Currently, Test::Harness does nothing with this information. + +=item B + +If the standard output line contains the substring C< # Skip> (with +variations in spacing and case) after C or C, it is +counted as a skipped test. If the whole testscript succeeds, the +count of skipped tests is included in the generated output. +C reports the text after C< # Skip\S*\s+> as a reason +for skipping. + + ok 23 # skip Insufficient flogiston pressure. + +Similarly, one can include a similar explanation in a C<1..0> line +emitted if the test script is skipped completely: + + 1..0 # Skipped: no leverage found + +=item B + +If the standard output line contains the substring C< # TODO> after +C or C, it is counted as a todo test. The text +afterwards is the thing that has to be done before this test will +succeed. + + not ok 13 # TODO harness the power of the atom + +=begin _deprecated + +Alternatively, you can specify a list of what tests are todo as part +of the test header. + + 1..23 todo 5 12 23 + +This only works if the header appears at the beginning of the test. + +This style is B. + +=end _deprecated + +These tests represent a feature to be implemented or a bug to be fixed +and act as something of an executable "thing to do" list. They are +B expected to succeed. Should a todo test begin succeeding, +Test::Harness will report it as a bonus. This indicates that whatever +you were supposed to do has been done and you should promote this to a +normal test. + +=item B + +As an emergency measure, a test script can decide that further tests +are useless (e.g. missing dependencies) and testing should stop +immediately. In that case the test script prints the magic words + + Bail out! + +to standard output. Any message after these words will be displayed by +C as the reason why testing is stopped. + +=item B + +Additional comments may be put into the testing output on their own +lines. Comment lines should begin with a '#', Test::Harness will +ignore them. + + ok 1 + # Life is good, the sun is shining, RAM is cheap. + not ok 2 + # got 'Bush' expected 'Gore' + +=item B + +Any other output Test::Harness sees it will silently ignore B If you wish to place additional output in your +test script, please use a comment. + +=back + + +=head2 Taint mode + +Test::Harness will honor the C<-T> in the #! line on your test files. So +if you begin a test with: + + #!perl -T + +the test will be run with taint mode on. + + +=head2 Configuration variables. + +These variables can be used to configure the behavior of +Test::Harness. They are exported on request. + +=over 4 + +=item B<$Test::Harness::verbose> + +The global variable $Test::Harness::verbose is exportable and can be +used to let runtests() display the standard output of the script +without altering the behavior otherwise. + +=item B<$Test::Harness::switches> + +The global variable $Test::Harness::switches is exportable and can be +used to set perl command line options used for running the test +script(s). The default value is C<-w>. + +=back + + +=head2 Failure + +It will happen, your tests will fail. After you mop up your ego, you +can begin examining the summary report: + + t/base..............ok + t/nonumbers.........ok + t/ok................ok + t/test-harness......ok + t/waterloo..........dubious + Test returned status 3 (wstat 768, 0x300) + DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19 + Failed 10/20 tests, 50.00% okay + Failed Test Stat Wstat Total Fail Failed List of Failed + ----------------------------------------------------------------------- + t/waterloo.t 3 768 20 10 50.00% 1 3 5 7 9 11 13 15 17 19 + Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay. + +Everything passed but t/waterloo.t. It failed 10 of 20 tests and +exited with non-zero status indicating something dubious happened. + +The columns in the summary report mean: + +=over 4 + +=item B + +The test file which failed. + +=item B + +If the test exited with non-zero, this is its exit status. + +=item B + +The wait status of the test I. + +=item B + +Total number of tests expected to run. + +=item B + +Number which failed, either from "not ok" or because they never ran. + +=item B + +Percentage of the total tests which failed. + +=item B + +A list of the tests which failed. Successive failures may be +abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and +20 failed). + +=back + + +=head2 Functions + +Test::Harness currently only has one function, here it is. + +=over 4 + +=item B + + my $allok = runtests(@test_files); + +This runs all the given @test_files and divines whether they passed +or failed based on their output to STDOUT (details above). It prints +out each individual test which failed along with a summary report and +a how long it all took. + +It returns true if everything was ok. Otherwise it will die() with +one of the messages in the DIAGNOSTICS section. + +=for _private + +This is just _run_all_tests() plus _show_results() + +=cut + +sub runtests { + my(@tests) = @_; + + local ($\, $,); + + my($tot, $failedtests) = _run_all_tests(@tests); + _show_results($tot, $failedtests); + + my $ok = _all_ok($tot); + + assert(($ok xor keys %$failedtests), + q{ok status jives with $failedtests}); + + return $ok; +} + +=begin _private + +=item B<_all_ok> + + my $ok = _all_ok(\%tot); + +Tells you if this test run is overall successful or not. + +=cut + +sub _all_ok { + my($tot) = shift; + + return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0; +} + +=item B<_globdir> + + my @files = _globdir $dir; + +Returns all the files in a directory. This is shorthand for backwards +compatibility on systems where glob() doesn't work right. + +=cut + +sub _globdir { + opendir DIRH, shift; + my @f = readdir DIRH; + closedir DIRH; + + return @f; +} + +=item B<_run_all_tests> + + my($total, $failed) = _run_all_tests(@test_files); + +Runs all the given @test_files (as runtests()) but does it quietly (no +report). $total is a hash ref summary of all the tests run. Its keys +and values are this: + + bonus Number of individual todo tests unexpectedly passed + max Number of individual tests ran + ok Number of individual tests passed + sub_skipped Number of individual tests skipped + todo Number of individual todo tests + + files Number of test files ran + good Number of test files passed + bad Number of test files failed + tests Number of test files originally given + skipped Number of test files skipped + +If $total->{bad} == 0 and $total->{max} > 0, you've got a successful +test. + +$failed is a hash ref of all the test scripts which failed. Each key +is the name of a test script, each value is another hash representing +how that script failed. Its keys are these: + + name Name of the test which failed + estat Script's exit value + wstat Script's wait status + max Number of individual tests + failed Number which failed + percent Percentage of tests which failed + canon List of tests which failed (as string). + +Needless to say, $failed should be empty if everything passed. + +B Currently this function is still noisy. I'm working on it. + +=cut + +#'# +sub _run_all_tests { + my(@tests) = @_; + local($|) = 1; + my(%failedtests); + + # Test-wide totals. + my(%tot) = ( + bonus => 0, + max => 0, + ok => 0, + files => 0, + bad => 0, + good => 0, + tests => scalar @tests, + sub_skipped => 0, + todo => 0, + skipped => 0, + bench => 0, + ); + + my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; + my $t_start = new Benchmark; + + my $width = _leader_width(@tests); + foreach my $tfile (@tests) { + $Last_ML_Print = 0; # so each test prints at least once + my($leader, $ml) = _mk_leader($tfile, $width); + local $ML = $ml; + print $leader; + + $tot{files}++; + + $Strap->{_seen_header} = 0; + my %results = $Strap->analyze_file($tfile) or + do { warn "$Strap->{error}\n"; next }; + + # state of the current test. + my @failed = grep { !$results{details}[$_-1]{ok} } + 1..@{$results{details}}; + my %test = ( + ok => $results{ok}, + 'next' => $Strap->{'next'}, + max => $results{max}, + failed => \@failed, + bonus => $results{bonus}, + skipped => $results{skip}, + skip_reason => $results{skip_reason}, + skip_all => $Strap->{skip_all}, + ml => $ml, + ); + + $tot{bonus} += $results{bonus}; + $tot{max} += $results{max}; + $tot{ok} += $results{ok}; + $tot{todo} += $results{todo}; + $tot{sub_skipped} += $results{skip}; + + my($estatus, $wstatus) = @results{qw(exit wait)}; + + if ($results{passing}) { + if ($test{max} and $test{skipped} + $test{bonus}) { + my @msg; + push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") + if $test{skipped}; + push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded") + if $test{bonus}; + print "$test{ml}ok\n ".join(', ', @msg)."\n"; + } elsif ($test{max}) { + print "$test{ml}ok\n"; + } elsif (defined $test{skip_all} and length $test{skip_all}) { + print "skipped\n all skipped: $test{skip_all}\n"; + $tot{skipped}++; + } else { + print "skipped\n all skipped: no reason given\n"; + $tot{skipped}++; + } + $tot{good}++; + } + else { + # List unrun tests as failures. + if ($test{'next'} <= $test{max}) { + push @{$test{failed}}, $test{'next'}..$test{max}; + } + # List overruns as failures. + else { + my $details = $results{details}; + foreach my $overrun ($test{max}+1..@$details) + { + next unless ref $details->[$overrun-1]; + push @{$test{failed}}, $overrun + } + } + + if ($wstatus) { + $failedtests{$tfile} = _dubious_return(\%test, \%tot, + $estatus, $wstatus); + $failedtests{$tfile}{name} = $tfile; + } + elsif($results{seen}) { + if (@{$test{failed}} and $test{max}) { + my ($txt, $canon) = canonfailed($test{max},$test{skipped}, + @{$test{failed}}); + print "$test{ml}$txt"; + $failedtests{$tfile} = { canon => $canon, + max => $test{max}, + failed => scalar @{$test{failed}}, + name => $tfile, + percent => 100*(scalar @{$test{failed}})/$test{max}, + estat => '', + wstat => '', + }; + } else { + print "Don't know which tests failed: got $test{ok} ok, ". + "expected $test{max}\n"; + $failedtests{$tfile} = { canon => '??', + max => $test{max}, + failed => '??', + name => $tfile, + percent => undef, + estat => '', + wstat => '', + }; + } + $tot{bad}++; + } else { + print "FAILED before any test output arrived\n"; + $tot{bad}++; + $failedtests{$tfile} = { canon => '??', + max => '??', + failed => '??', + name => $tfile, + percent => undef, + estat => '', + wstat => '', + }; + } + } + + if (defined $Files_In_Dir) { + my @new_dir_files = _globdir $Files_In_Dir; + if (@new_dir_files != @dir_files) { + my %f; + @f{@new_dir_files} = (1) x @new_dir_files; + delete @f{@dir_files}; + my @f = sort keys %f; + print "LEAKED FILES: @f\n"; + @dir_files = @new_dir_files; + } + } + } + $tot{bench} = timediff(new Benchmark, $t_start); + + $Strap->_restore_PERL5LIB; + + return(\%tot, \%failedtests); +} + +=item B<_mk_leader> + + my($leader, $ml) = _mk_leader($test_file, $width); + +Generates the 't/foo........' $leader for the given $test_file as well +as a similar version which will overwrite the current line (by use of +\r and such). $ml may be empty if Test::Harness doesn't think you're +on TTY. + +The $width is the width of the "yada/blah.." string. + +=cut + +sub _mk_leader { + my($te, $width) = @_; + chomp($te); + $te =~ s/\.\w+$/./; + + if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; } + my $blank = (' ' x 77); + my $leader = "$te" . '.' x ($width - length($te)); + my $ml = ""; + + $ml = "\r$blank\r$leader" + if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose; + + return($leader, $ml); +} + +=item B<_leader_width> + + my($width) = _leader_width(@test_files); + +Calculates how wide the leader should be based on the length of the +longest test name. + +=cut + +sub _leader_width { + my $maxlen = 0; + my $maxsuflen = 0; + foreach (@_) { + my $suf = /\.(\w+)$/ ? $1 : ''; + my $len = length; + my $suflen = length $suf; + $maxlen = $len if $len > $maxlen; + $maxsuflen = $suflen if $suflen > $maxsuflen; + } + # + 3 : we want three dots between the test name and the "ok" + return $maxlen + 3 - $maxsuflen; +} + + +sub _show_results { + my($tot, $failedtests) = @_; + + my $pct; + my $bonusmsg = _bonusmsg($tot); + + if (_all_ok($tot)) { + print "All tests successful$bonusmsg.\n"; + } elsif (!$tot->{tests}){ + die "FAILED--no tests were run for some reason.\n"; + } elsif (!$tot->{max}) { + my $blurb = $tot->{tests}==1 ? "script" : "scripts"; + die "FAILED--$tot->{tests} test $blurb could be run, ". + "alas--no output ever seen\n"; + } else { + $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100); + my $percent_ok = 100*$tot->{ok}/$tot->{max}; + my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", + $tot->{max} - $tot->{ok}, $tot->{max}, + $percent_ok; + + my($fmt_top, $fmt) = _create_fmts($failedtests); + + # Now write to formats + for my $script (sort keys %$failedtests) { + $Curtest = $failedtests->{$script}; + write; + } + if ($tot->{bad}) { + $bonusmsg =~ s/^,\s*//; + print "$bonusmsg.\n" if $bonusmsg; + die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.". + "$subpct\n"; + } + } + + printf("Files=%d, Tests=%d, %s\n", + $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); +} + + +my %Handlers = (); +$Strap->{callback} = sub { + my($self, $line, $type, $totals) = @_; + print $line if $Verbose; + + my $meth = $Handlers{$type}; + $meth->($self, $line, $type, $totals) if $meth; +}; + + +$Handlers{header} = sub { + my($self, $line, $type, $totals) = @_; + + warn "Test header seen more than once!\n" if $self->{_seen_header}; + + $self->{_seen_header}++; + + warn "1..M can only appear at the beginning or end of tests\n" + if $totals->{seen} && + $totals->{max} < $totals->{seen}; +}; + +$Handlers{test} = sub { + my($self, $line, $type, $totals) = @_; + + my $curr = $totals->{seen}; + my $next = $self->{'next'}; + my $max = $totals->{max}; + my $detail = $totals->{details}[-1]; + + if( $detail->{ok} ) { + _print_ml_less("ok $curr/$max"); + + if( $detail->{type} eq 'skip' ) { + $totals->{skip_reason} = $detail->{reason} + unless defined $totals->{skip_reason}; + $totals->{skip_reason} = 'various reasons' + if $totals->{skip_reason} ne $detail->{reason}; + } + } + else { + _print_ml("NOK $curr"); + } + + if( $curr > $next ) { + print "Test output counter mismatch [test $curr]\n"; + } + elsif( $curr < $next ) { + print "Confused test output: test $curr answered after ". + "test ", $next - 1, "\n"; + } + +}; + +$Handlers{bailout} = sub { + my($self, $line, $type, $totals) = @_; + + die "FAILED--Further testing stopped" . + ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); +}; + + +sub _print_ml { + print join '', $ML, @_ if $ML; +} + + +# For slow connections, we save lots of bandwidth by printing only once +# per second. +sub _print_ml_less { + if( !$Ok_Slow || $Last_ML_Print != time ) { + _print_ml(@_); + $Last_ML_Print = time; + } +} + +sub _bonusmsg { + my($tot) = @_; + + my $bonusmsg = ''; + $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). + " UNEXPECTEDLY SUCCEEDED)") + if $tot->{bonus}; + + if ($tot->{skipped}) { + $bonusmsg .= ", $tot->{skipped} test" + . ($tot->{skipped} != 1 ? 's' : ''); + if ($tot->{sub_skipped}) { + $bonusmsg .= " and $tot->{sub_skipped} subtest" + . ($tot->{sub_skipped} != 1 ? 's' : ''); + } + $bonusmsg .= ' skipped'; + } + elsif ($tot->{sub_skipped}) { + $bonusmsg .= ", $tot->{sub_skipped} subtest" + . ($tot->{sub_skipped} != 1 ? 's' : '') + . " skipped"; + } + + return $bonusmsg; +} + +# Test program go boom. +sub _dubious_return { + my($test, $tot, $estatus, $wstatus) = @_; + my ($failed, $canon, $percent) = ('??', '??'); + + printf "$test->{ml}dubious\n\tTest returned status $estatus ". + "(wstat %d, 0x%x)\n", + $wstatus,$wstatus; + print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; + + if (corestatus($wstatus)) { # until we have a wait module + if ($Have_Devel_Corestack) { + Devel::CoreStack::stack($^X); + } else { + print "\ttest program seems to have generated a core\n"; + } + } + + $tot->{bad}++; + + if ($test->{max}) { + if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) { + print "\tafter all the subtests completed successfully\n"; + $percent = 0; + $failed = 0; # But we do not set $canon! + } + else { + push @{$test->{failed}}, $test->{'next'}..$test->{max}; + $failed = @{$test->{failed}}; + (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}}); + $percent = 100*(scalar @{$test->{failed}})/$test->{max}; + print "DIED. ",$txt; + } + } + + return { canon => $canon, max => $test->{max} || '??', + failed => $failed, + percent => $percent, + estat => $estatus, wstat => $wstatus, + }; +} + + +sub _create_fmts { + my($failedtests) = @_; + + my $failed_str = "Failed Test"; + my $middle_str = " Stat Wstat Total Fail Failed "; + my $list_str = "List of Failed"; + + # Figure out our longest name string for formatting purposes. + my $max_namelen = length($failed_str); + foreach my $script (keys %$failedtests) { + my $namelen = length $failedtests->{$script}->{name}; + $max_namelen = $namelen if $namelen > $max_namelen; + } + + my $list_len = $Columns - length($middle_str) - $max_namelen; + if ($list_len < length($list_str)) { + $list_len = length($list_str); + $max_namelen = $Columns - length($middle_str) - $list_len; + if ($max_namelen < length($failed_str)) { + $max_namelen = length($failed_str); + $Columns = $max_namelen + length($middle_str) + $list_len; + } + } + + my $fmt_top = "format STDOUT_TOP =\n" + . sprintf("%-${max_namelen}s", $failed_str) + . $middle_str + . $list_str . "\n" + . "-" x $Columns + . "\n.\n"; + + my $fmt = "format STDOUT =\n" + . "@" . "<" x ($max_namelen - 1) + . " @>> @>>>> @>>>> @>>> ^##.##% " + . "^" . "<" x ($list_len - 1) . "\n" + . '{ $Curtest->{name}, $Curtest->{estat},' + . ' $Curtest->{wstat}, $Curtest->{max},' + . ' $Curtest->{failed}, $Curtest->{percent},' + . ' $Curtest->{canon}' + . "\n}\n" + . "~~" . " " x ($Columns - $list_len - 2) . "^" + . "<" x ($list_len - 1) . "\n" + . '$Curtest->{canon}' + . "\n.\n"; + + eval $fmt_top; + die $@ if $@; + eval $fmt; + die $@ if $@; + + return($fmt_top, $fmt); +} + +{ + my $tried_devel_corestack; + + sub corestatus { + my($st) = @_; + + my $did_core; + eval { # we may not have a WCOREDUMP + local $^W = 0; # *.ph files are often *very* noisy + require 'wait.ph'; + $did_core = WCOREDUMP($st); + }; + if( $@ ) { + $did_core = $st & 0200; + } + + eval { require Devel::CoreStack; $Have_Devel_Corestack++ } + unless $tried_devel_corestack++; + + return $did_core; + } +} + +sub canonfailed ($$@) { + my($max,$skipped,@failed) = @_; + my %seen; + @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; + my $failed = @failed; + my @result = (); + my @canon = (); + my $min; + my $last = $min = shift @failed; + my $canon; + if (@failed) { + for (@failed, $failed[-1]) { # don't forget the last one + if ($_ > $last+1 || $_ == $last) { + if ($min == $last) { + push @canon, $last; + } else { + push @canon, "$min-$last"; + } + $min = $_; + } + $last = $_; + } + local $" = ", "; + push @result, "FAILED tests @canon\n"; + $canon = join ' ', @canon; + } else { + push @result, "FAILED test $last\n"; + $canon = $last; + } + + push @result, "\tFailed $failed/$max tests, "; + if ($max) { + push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay"; + } else { + push @result, "?% okay"; + } + my $ender = 's' x ($skipped > 1); + my $good = $max - $failed - $skipped; + if ($skipped) { + my $skipmsg = " (less $skipped skipped test$ender: $good okay, "; + if ($max) { + my $goodper = sprintf("%.2f",100*($good/$max)); + $skipmsg .= "$goodper%)"; + } else { + $skipmsg .= "?%)"; + } + push @result, $skipmsg; + } + push @result, "\n"; + my $txt = join "", @result; + ($txt, $canon); +} + +=end _private + +=back + +=cut + + +1; +__END__ + + +=head1 EXPORT + +C<&runtests> is exported by Test::Harness by default. + +C<$verbose> and C<$switches> are exported upon request. + + +=head1 DIAGNOSTICS + +=over 4 + +=item C + +If all tests are successful some statistics about the performance are +printed. + +=item C + +For any single script that has failing subtests statistics like the +above are printed. + +=item C + +Scripts that return a non-zero exit status, both C<$? EE 8> +and C<$?> are printed in a message similar to the above. + +=item C + +=item C + +If not all tests were successful, the script dies with one of the +above messages. + +=item C + +If a single subtest decides that further testing will not make sense, +the script dies with this message. + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item C + +Harness sets this before executing the individual tests. This allows +the tests to determine if they are being executed through the harness +or by any other means. + +=item C + +This value will be used for the width of the terminal. If it is not +set then it will default to C. If this is not set, it will +default to 80. Note that users of Bourne-sh based shells will need to +C for this module to use that variable. + +=item C + +When true it will make harness attempt to compile the test using +C before running it. + +B This currently only works when sitting in the perl source +directory! + +=item C + +When set to the name of a directory, harness will check after each +test whether new files appeared in that directory, and report them as + + LEAKED FILES: scr.tmp 0 my.db + +If relative, directory name is with respect to the current directory at +the moment runtests() was called. Putting absolute path into +C may give more predictable results. + +=item C + +Makes harness ignore the exit status of child processes when defined. + +=item C + +When set to a true value, forces it to behave as though STDOUT were +not a console. You may need to set this if you don't want harness to +output more frequent progress messages using carriage returns. Some +consoles may not handle carriage returns properly (which results in a +somewhat messy output). + +=item C + +If true, the C messages are printed out only every second. +This reduces output and therefore may for example help testing +over slow connections. + +=item C + +Its value will be prepended to the switches used to invoke perl on +each test. For example, setting C to C<-W> will +run all tests with all warnings enabled. + +=item C + +If true, Test::Harness will output the verbose results of running +its tests. Setting $Test::Harness::verbose will override this. + +=back + +=head1 EXAMPLE + +Here's how Test::Harness tests itself + + $ cd ~/src/devel/Test-Harness + $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose); + $verbose=0; runtests @ARGV;' t/*.t + Using /home/schwern/src/devel/Test-Harness/blib + t/base..............ok + t/nonumbers.........ok + t/ok................ok + t/test-harness......ok + All tests successful. + Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU) + +=head1 SEE ALSO + +L and L for writing test scripts, L for +the underlying timing routines, L to generate core +dumps from failed tests and L for test coverage +analysis. + +=head1 AUTHORS + +Either Tim Bunce or Andreas Koenig, we don't know. What we know for +sure is, that it was inspired by Larry Wall's TEST script that came +with perl distributions for ages. Numerous anonymous contributors +exist. Andreas Koenig held the torch for many years, and then +Michael G Schwern. + +Current maintainer is Andy Lester C<< >>. + +=head1 LICENSE + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L + +=head1 TODO + +Provide a way of running tests quietly (ie. no printing) for automated +validation of tests. This will probably take the form of a version +of runtests() which rather than printing its output returns raw data +on the state of the tests. (Partially done in Test::Harness::Straps) + +Document the format. + +Fix HARNESS_COMPILE_TEST without breaking its core usage. + +Figure a way to report test names in the failure summary. + +Rework the test summary so long test names are not truncated as badly. +(Partially done with new skip test styles) + +Deal with VMS's "not \nok 4\n" mistake. + +Add option for coverage analysis. + +Trap STDERR. + +Implement Straps total_results() + +Remember exit code + +Completely redo the print summary code. + +Implement Straps callbacks. (experimentally implemented) + +Straps->analyze_file() not taint clean, don't know if it can be + +Fix that damned VMS nit. + +HARNESS_TODOFAIL to display TODO failures + +Add a test for verbose. + +Change internal list of test results to a hash. + +Fix stats display when there's an overrun. + +Fix so perls with spaces in the filename work. + +=for _private + +Keeping whittling away at _run_all_tests() + +=for _private + +Clean up how the summary is printed. Get rid of those damned formats. + +=head1 BUGS + +HARNESS_COMPILE_TEST currently assumes it's run from the Perl source +directory. + +=cut diff --git a/Perl/t/Test/Harness/Assert.pm b/Perl/t/Test/Harness/Assert.pm new file mode 100644 index 0000000..3ee23e3 --- /dev/null +++ b/Perl/t/Test/Harness/Assert.pm @@ -0,0 +1,68 @@ +# $Id$ + +package Test::Harness::Assert; + +use strict; +require Exporter; +use vars qw($VERSION @EXPORT @ISA); + +$VERSION = '0.01'; + +@ISA = qw(Exporter); +@EXPORT = qw(assert); + + +=head1 NAME + +Test::Harness::Assert - simple assert + +=head1 SYNOPSIS + + ### FOR INTERNAL USE ONLY ### + + use Test::Harness::Assert; + + assert( EXPR, $name ); + +=head1 DESCRIPTION + +A simple assert routine since we don't have Carp::Assert handy. + +B + +=head2 Functions + +=over 4 + +=item B + + assert( EXPR, $name ); + +If the expression is false the program aborts. + +=cut + +sub assert ($;$) { + my($assert, $name) = @_; + + unless( $assert ) { + require Carp; + my $msg = 'Assert failed'; + $msg .= " - '$name'" if defined $name; + $msg .= '!'; + Carp::croak($msg); + } + +} + +=head1 AUTHOR + +Michael G Schwern Eschwern@pobox.comE + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/Perl/t/Test/Harness/Iterator.pm b/Perl/t/Test/Harness/Iterator.pm new file mode 100644 index 0000000..5e22793 --- /dev/null +++ b/Perl/t/Test/Harness/Iterator.pm @@ -0,0 +1,61 @@ +package Test::Harness::Iterator; + +use strict; +use vars qw($VERSION); +$VERSION = 0.01; + + +=head1 NAME + +Test::Harness::Iterator - Internal Test::Harness Iterator + +=head1 SYNOPSIS + + use Test::Harness::Iterator; + use Test::Harness::Iterator; + my $it = Test::Harness::Iterator->new(\*TEST); + my $it = Test::Harness::Iterator->new(\@array); + + my $line = $it->next; + + +=head1 DESCRIPTION + +B + +This is a simple iterator wrapper for arrays and filehandles. + +=cut + +sub new { + my($proto, $thing) = @_; + + my $self = {}; + if( ref $thing eq 'GLOB' ) { + bless $self, 'Test::Harness::Iterator::FH'; + $self->{fh} = $thing; + } + elsif( ref $thing eq 'ARRAY' ) { + bless $self, 'Test::Harness::Iterator::ARRAY'; + $self->{idx} = 0; + $self->{array} = $thing; + } + else { + warn "Can't iterate with a ", ref $thing; + } + + return $self; +} + +package Test::Harness::Iterator::FH; +sub next { + my $fh = $_[0]->{fh}; + return scalar <$fh>; +} + + +package Test::Harness::Iterator::ARRAY; +sub next { + my $self = shift; + return $self->{array}->[$self->{idx}++]; +} diff --git a/Perl/t/Test/Harness/Straps.pm b/Perl/t/Test/Harness/Straps.pm new file mode 100644 index 0000000..4d971b7 --- /dev/null +++ b/Perl/t/Test/Harness/Straps.pm @@ -0,0 +1,667 @@ +# -*- Mode: cperl; cperl-indent-level: 4 -*- +# $Id$ + +package Test::Harness::Straps; + +use strict; +use vars qw($VERSION); +use Config; +$VERSION = '0.15'; + +use Test::Harness::Assert; +use Test::Harness::Iterator; + +# Flags used as return values from our methods. Just for internal +# clarification. +my $TRUE = (1==1); +my $FALSE = !$TRUE; +my $YES = $TRUE; +my $NO = $FALSE; + + +=head1 NAME + +Test::Harness::Straps - detailed analysis of test results + +=head1 SYNOPSIS + + use Test::Harness::Straps; + + my $strap = Test::Harness::Straps->new; + + # Various ways to interpret a test + my %results = $strap->analyze($name, \@test_output); + my %results = $strap->analyze_fh($name, $test_filehandle); + my %results = $strap->analyze_file($test_file); + + # UNIMPLEMENTED + my %total = $strap->total_results; + + # Altering the behavior of the strap UNIMPLEMENTED + my $verbose_output = $strap->dump_verbose(); + $strap->dump_verbose_fh($output_filehandle); + + +=head1 DESCRIPTION + +B in that the interface is subject to change +in incompatible ways. It is otherwise stable. + +Test::Harness is limited to printing out its results. This makes +analysis of the test results difficult for anything but a human. To +make it easier for programs to work with test results, we provide +Test::Harness::Straps. Instead of printing the results, straps +provide them as raw data. You can also configure how the tests are to +be run. + +The interface is currently incomplete. I contact the author +if you'd like a feature added or something change or just have +comments. + +=head1 Construction + +=head2 C + + my $strap = Test::Harness::Straps->new; + +Initialize a new strap. + +=cut + +sub new { + my($proto) = shift; + my($class) = ref $proto || $proto; + + my $self = bless {}, $class; + $self->_init; + + return $self; +} + +=head2 C<_init> + + $strap->_init; + +Initialize the internal state of a strap to make it ready for parsing. + +=cut + +sub _init { + my($self) = shift; + + $self->{_is_vms} = $^O eq 'VMS'; + $self->{_is_win32} = $^O eq 'Win32'; +} + +=head1 Analysis + +=head2 C + + my %results = $strap->analyze($name, \@test_output); + +Analyzes the output of a single test, assigning it the given C<$name> +for use in the total report. Returns the C<%results> of the test. +See L. + +C<@test_output> should be the raw output from the test, including +newlines. + +=cut + +sub analyze { + my($self, $name, $test_output) = @_; + + my $it = Test::Harness::Iterator->new($test_output); + return $self->_analyze_iterator($name, $it); +} + + +sub _analyze_iterator { + my($self, $name, $it) = @_; + + $self->_reset_file_state; + $self->{file} = $name; + my %totals = ( + max => 0, + seen => 0, + + ok => 0, + todo => 0, + skip => 0, + bonus => 0, + + details => [] + ); + + # Set them up here so callbacks can have them. + $self->{totals}{$name} = \%totals; + while( defined(my $line = $it->next) ) { + $self->_analyze_line($line, \%totals); + last if $self->{saw_bailout}; + } + + $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all}; + + my $passed = ($totals{max} == 0 && defined $totals{skip_all}) || + ($totals{max} && $totals{seen} && + $totals{max} == $totals{seen} && + $totals{max} == $totals{ok}); + $totals{passing} = $passed ? 1 : 0; + + return %totals; +} + + +sub _analyze_line { + my($self, $line, $totals) = @_; + + my %result = (); + + $self->{line}++; + + my $type; + if( $self->_is_header($line) ) { + $type = 'header'; + + $self->{saw_header}++; + + $totals->{max} += $self->{max}; + } + elsif( $self->_is_test($line, \%result) ) { + $type = 'test'; + + $totals->{seen}++; + $result{number} = $self->{'next'} unless $result{number}; + + # sometimes the 'not ' and the 'ok' are on different lines, + # happens often on VMS if you do: + # print "not " unless $test; + # print "ok $num\n"; + if( $self->{saw_lone_not} && + ($self->{lone_not_line} == $self->{line} - 1) ) + { + $result{ok} = 0; + } + + my $pass = $result{ok}; + $result{type} = 'todo' if $self->{todo}{$result{number}}; + + if( $result{type} eq 'todo' ) { + $totals->{todo}++; + $pass = 1; + $totals->{bonus}++ if $result{ok} + } + elsif( $result{type} eq 'skip' ) { + $totals->{skip}++; + $pass = 1; + } + + $totals->{ok}++ if $pass; + + if( $result{number} > 100000 && $result{number} > $self->{max} ) { + warn "Enormous test number seen [test $result{number}]\n"; + warn "Can't detailize, too big.\n"; + } + else { + $totals->{details}[$result{number} - 1] = + {$self->_detailize($pass, \%result)}; + } + + # XXX handle counter mismatch + } + elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { + $type = 'bailout'; + $self->{saw_bailout} = 1; + } + else { + $type = 'other'; + } + + $self->{callback}->($self, $line, $type, $totals) if $self->{callback}; + + $self->{'next'} = $result{number} + 1 if $type eq 'test'; +} + +=head2 C + + my %results = $strap->analyze_fh($name, $test_filehandle); + +Like C, but it reads from the given filehandle. + +=cut + +sub analyze_fh { + my($self, $name, $fh) = @_; + + my $it = Test::Harness::Iterator->new($fh); + $self->_analyze_iterator($name, $it); +} + +=head2 C + + my %results = $strap->analyze_file($test_file); + +Like C, but it runs the given C<$test_file> and parses its +results. It will also use that name for the total report. + +=cut + +sub analyze_file { + my($self, $file) = @_; + + unless( -e $file ) { + $self->{error} = "$file does not exist"; + return; + } + + unless( -r $file ) { + $self->{error} = "$file is not readable"; + return; + } + + local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; + + my $cmd = $self->{_is_vms} ? "MCR $^X" : + $self->{_is_win32} ? Win32::GetShortPathName($^X) + : $^X; + + my $switches = $self->_switches($file); + + # *sigh* this breaks under taint, but open -| is unportable. + unless( open(FILE, "$cmd $switches $file|") ) { + print "can't run $file. $!\n"; + return; + } + + my %results = $self->analyze_fh($file, \*FILE); + my $exit = close FILE; + $results{'wait'} = $?; + if( $? && $self->{_is_vms} ) { + eval q{use vmsish "status"; $results{'exit'} = $?}; + } + else { + $results{'exit'} = _wait2exit($?); + } + $results{passing} = 0 unless $? == 0; + + $self->_restore_PERL5LIB(); + + return %results; +} + + +eval { require POSIX; &POSIX::WEXITSTATUS(0) }; +if( $@ ) { + *_wait2exit = sub { $_[0] >> 8 }; +} +else { + *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } +} + + +=head2 C<_switches> + + my $switches = $self->_switches($file); + +Formats and returns the switches necessary to run the test. + +=cut + +sub _switches { + my($self, $file) = @_; + + local *TEST; + open(TEST, $file) or print "can't open $file. $!\n"; + my $first = ; + my $s = $Test::Harness::Switches || ''; + $s .= " $ENV{'HARNESS_PERL_SWITCHES'}" + if exists $ENV{'HARNESS_PERL_SWITCHES'}; + + if ($first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/) { + # When taint mode is on, PERL5LIB is ignored. So we need to put + # all that on the command line as -Is. + $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} $self->_filtered_INC; + } + elsif ($^O eq 'MacOS') { + # MacPerl's putenv is broken, so it will not see PERL5LIB. + $s .= join " ", map {qq["-I$_"]} $self->_filtered_INC; + } + + close(TEST) or print "can't close $file. $!\n"; + + return $s; +} + + +=head2 C<_INC2PERL5LIB> + + local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; + +Takes the current value of C<@INC> and turns it into something suitable +for putting onto C. + +=cut + +sub _INC2PERL5LIB { + my($self) = shift; + + $self->{_old5lib} = $ENV{PERL5LIB}; + + return join $Config{path_sep}, $self->_filtered_INC; +} + +=head2 C<_filtered_INC> + + my @filtered_inc = $self->_filtered_INC; + +Shortens C<@INC> by removing redundant and unnecessary entries. +Necessary for OSes with limited command line lengths, like VMS. + +=cut + +sub _filtered_INC { + my($self, @inc) = @_; + @inc = @INC unless @inc; + + # VMS has a 255-byte limit on the length of %ENV entries, so + # toss the ones that involve perl_root, the install location + # for VMS + if( $self->{_is_vms} ) { + @inc = grep !/perl_root/i, @inc; + } + + return @inc; +} + + +=head2 C<_restore_PERL5LIB> + + $self->_restore_PERL5LIB; + +This restores the original value of the C environment variable. +Necessary on VMS, otherwise a no-op. + +=cut + +sub _restore_PERL5LIB { + my($self) = shift; + + return unless $self->{_is_vms}; + + if (defined $self->{_old5lib}) { + $ENV{PERL5LIB} = $self->{_old5lib}; + } +} + +=head1 Parsing + +Methods for identifying what sort of line you're looking at. + +=head2 C<_is_comment> + + my $is_comment = $strap->_is_comment($line, \$comment); + +Checks if the given line is a comment. If so, it will place it into +C<$comment> (sans #). + +=cut + +sub _is_comment { + my($self, $line, $comment) = @_; + + if( $line =~ /^\s*\#(.*)/ ) { + $$comment = $1; + return $YES; + } + else { + return $NO; + } +} + +=head2 C<_is_header> + + my $is_header = $strap->_is_header($line); + +Checks if the given line is a header (1..M) line. If so, it places how +many tests there will be in C<< $strap->{max} >>, a list of which tests +are todo in C<< $strap->{todo} >> and if the whole test was skipped +C<< $strap->{skip_all} >> contains the reason. + +=cut + +# Regex for parsing a header. Will be run with /x +my $Extra_Header_Re = <<'REGEX'; + ^ + (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set + (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason +REGEX + +sub _is_header { + my($self, $line) = @_; + + if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { + $self->{max} = $max; + assert( $self->{max} >= 0, 'Max # of tests looks right' ); + + if( defined $extra ) { + my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; + + $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; + + if( $self->{max} == 0 ) { + $reason = '' unless defined $skip and $skip =~ /^Skip/i; + } + + $self->{skip_all} = $reason; + } + + return $YES; + } + else { + return $NO; + } +} + +=head2 C<_is_test> + + my $is_test = $strap->_is_test($line, \%test); + +Checks if the $line is a test report (ie. 'ok/not ok'). Reports the +result back in C<%test> which will contain: + + ok did it succeed? This is the literal 'ok' or 'not ok'. + name name of the test (if any) + number test number (if any) + + type 'todo' or 'skip' (if any) + reason why is it todo or skip? (if any) + +If will also catch lone 'not' lines, note it saw them +C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>. + +=cut + +my $Report_Re = <<'REGEX'; + ^ + (not\ )? # failure? + ok\b + (?:\s+(\d+))? # optional test number + \s* + (.*) # and the rest +REGEX + +my $Extra_Re = <<'REGEX'; + ^ + (.*?) (?:(?:[^\\]|^)# (.*))? + $ +REGEX + +sub _is_test { + my($self, $line, $test) = @_; + + # We pulverize the line down into pieces in three parts. + if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) { + my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra; + my($type, $reason) = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control; + + $test->{number} = $num; + $test->{ok} = $not ? 0 : 1; + $test->{name} = $name; + + if( defined $type ) { + $test->{type} = $type =~ /^TODO$/i ? 'todo' : + $type =~ /^Skip/i ? 'skip' : 0; + } + else { + $test->{type} = ''; + } + $test->{reason} = $reason; + + return $YES; + } + else{ + # Sometimes the "not " and "ok" will be on seperate lines on VMS. + # We catch this and remember we saw it. + if( $line =~ /^not\s+$/ ) { + $self->{saw_lone_not} = 1; + $self->{lone_not_line} = $self->{line}; + } + + return $NO; + } +} + +=head2 C<_is_bail_out> + + my $is_bail_out = $strap->_is_bail_out($line, \$reason); + +Checks if the line is a "Bail out!". Places the reason for bailing +(if any) in $reason. + +=cut + +sub _is_bail_out { + my($self, $line, $reason) = @_; + + if( $line =~ /^Bail out!\s*(.*)/i ) { + $$reason = $1 if $1; + return $YES; + } + else { + return $NO; + } +} + +=head2 C<_reset_file_state> + + $strap->_reset_file_state; + +Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, +etc. so it's ready to parse the next file. + +=cut + +sub _reset_file_state { + my($self) = shift; + + delete @{$self}{qw(max skip_all todo)}; + $self->{line} = 0; + $self->{saw_header} = 0; + $self->{saw_bailout}= 0; + $self->{saw_lone_not} = 0; + $self->{lone_not_line} = 0; + $self->{bailout_reason} = ''; + $self->{'next'} = 1; +} + +=head1 Results + +The C<%results> returned from C contain the following +information: + + passing true if the whole test is considered a pass + (or skipped), false if its a failure + + exit the exit code of the test run, if from a file + wait the wait code of the test run, if from a file + + max total tests which should have been run + seen total tests actually seen + skip_all if the whole test was skipped, this will + contain the reason. + + ok number of tests which passed + (including todo and skips) + + todo number of todo tests seen + bonus number of todo tests which + unexpectedly passed + + skip number of tests skipped + +So a successful test should have max == seen == ok. + + +There is one final item, the details. + + details an array ref reporting the result of + each test looks like this: + + $results{details}[$test_num - 1] = + { ok => is the test considered ok? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => 'skip' or 'todo' (if any) + reason => reason for the above (if any) + }; + +Element 0 of the details is test #1. I tried it with element 1 being +#1 and 0 being empty, this is less awkward. + +=head2 C<_detailize> + + my %details = $strap->_detailize($pass, \%test); + +Generates the details based on the last test line seen. C<$pass> is +true if it was considered to be a passed test. C<%test> is the results +of the test you're summarizing. + +=cut + +sub _detailize { + my($self, $pass, $test) = @_; + + my %details = ( ok => $pass, + actual_ok => $test->{ok} + ); + + assert( !(grep !defined $details{$_}, keys %details), + 'test contains the ok and actual_ok info' ); + + # We don't want these to be undef because they are often + # checked and don't want the checker to have to deal with + # uninitialized vars. + foreach my $piece (qw(name type reason)) { + $details{$piece} = defined $test->{$piece} ? $test->{$piece} : ''; + } + + return %details; +} + +=head1 EXAMPLES + +See F for an example of use. + +=head1 AUTHOR + +Michael G Schwern C<< >>, currently maintained by +Andy Lester C<< >>. + +=head1 SEE ALSO + +L + +=cut + + +1; diff --git a/Perl/t/Test/More.pm b/Perl/t/Test/More.pm new file mode 100644 index 0000000..03f7552 --- /dev/null +++ b/Perl/t/Test/More.pm @@ -0,0 +1,1248 @@ +package Test::More; + +use 5.004; + +use strict; +use Test::Builder; + + +# 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"; +} + + + +require Exporter; +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = '0.47'; +@ISA = qw(Exporter); +@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 + ); + +my $Test = Test::Builder->new; + + +# 5.004's Exporter doesn't have export_to_level. +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + # or + use Test::More qw(no_plan); + # or + use Test::More skip_all => $reason; + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($this eq $that, $test_name); + + is ($this, $that, $test_name); + isnt($this, $that, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($this, qr/that/, $test_name); + unlike($this, qr/that/, $test_name); + + cmp_ok($this, '==', $that, $test_name); + + is_deeply($complex_structure1, $complex_structure2, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + # Utility comparison functions. + eq_array(\@this, \@that); + eq_hash(\%this, \%that); + eq_set(\@this, \@that); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + # UNIMPLEMENTED!!! + BAIL_OUT($why); + + +=head1 DESCRIPTION + +B If you're just getting started writing tests, have a look at +Test::Simple first. This is a drop in replacement for Test::Simple +which you can switch to once you get the hang of basic testing. + +The purpose of this module is to provide a wide range of testing +utilities. Various ways to say "ok" with better diagnostics, +facilities to skip tests, test future features and compare complicated +data structures. While you can do almost anything with a simple +C function, it doesn't provide good diagnostic output. + + +=head2 I love it when a plan comes together + +Before anything else, you need a testing plan. This basically declares +how many tests your script is going to run to protect against premature +failure. + +The preferred way to do this is to declare a plan when you C. + + use Test::More tests => $Num_Tests; + +There are rare cases when you will not know beforehand how many tests +your script is going to run. In this case, you can declare that you +have no plan. (Try to avoid using this as it weakens your test.) + + use Test::More qw(no_plan); + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More skip_all => $skip_reason; + +Your script will declare a skip with the reason why you skipped and +exit immediately with a zero (success). See L for +details. + +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the plan() function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevant on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my(@plan) = @_; + + my $caller = caller; + + $Test->exported_to($caller); + + my @imports = (); + foreach my $idx (0..$#plan) { + if( $plan[$idx] eq 'import' ) { + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; + last; + } + } + + $Test->plan(@plan); + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + +sub import { + my($class) = shift; + goto &plan; +} + + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, it's often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. It's optional, but highly +suggested that you use it. + + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B + + ok($this eq $that, $test_name); + +This simply evaluates any expression (C<$this eq $that> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep !defined $_, @items, 'items populated' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B strongly encourage its use. + +Should an ok() fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 18 (foo.t at line 42) + +This is actually Test::Simple's ok() routine. + +=cut + +sub ok ($;$) { + my($test, $name) = @_; + $Test->ok($test, $name); +} + +=item B + +=item B + + is ( $this, $that, $test_name ); + isnt( $this, $that, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments +with C and C respectively and use the result of that to +determine if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. ok() +cannot know what you are testing for (beyond the name), but is() and +isnt() know what the test was and why it failed. For example this +test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test (foo.t at line 139) + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use is() and isnt() over ok() where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! $pope->isa('Catholic') eq 1 + is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); + +This does not check if C<$pope->isa('Catholic')> is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use ok(). + + ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); + +For those grammatical pedants out there, there's an C +function which is an alias of isnt(). + +=cut + +sub is ($$;$) { + $Test->is_eq(@_); +} + +sub isnt ($$;$) { + $Test->isnt_eq(@_); +} + +*isn't = \&isnt; + + +=item B + + like( $this, qr/that/, $test_name ); + +Similar to ok(), like() matches $this against the regex C. + +So this: + + like($this, qr/that/, 'this is like that'); + +is similar to: + + ok( $this =~ /that/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (i.e. C) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $this, '/that/', 'this is like that' ); + +Regex options may be placed on the end (C<'/that/i'>). + +Its advantages over ok() are similar to that of is() and isnt(). Better +diagnostics on failure. + +=cut + +sub like ($$;$) { + $Test->like(@_); +} + + +=item B + + unlike( $this, qr/that/, $test_name ); + +Works exactly as like(), only it checks if $this B match the +given pattern. + +=cut + +sub unlike { + $Test->unlike(@_); +} + + +=item B + + cmp_ok( $this, $op, $that, $test_name ); + +Halfway between ok() and is() lies cmp_ok(). This allows you to +compare two arguments using any binary perl operator. + + # ok( $this eq $that ); + cmp_ok( $this, 'eq', $that, 'this eq that' ); + + # ok( $this == $that ); + cmp_ok( $this, '==', $that, 'this == that' ); + + # ok( $this && $that ); + cmp_ok( $this, '&&', $that, 'this || that' ); + ...etc... + +Its advantage over ok() is when the test fails you'll know what $this +and $that were: + + not ok 1 + # Failed test (foo.t at line 12) + # '23' + # && + # undef + +It's also useful in those cases where you are comparing numbers and +is()'s use of C will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +=cut + +sub cmp_ok($$$;$) { + $Test->cmp_ok(@_); +} + + +=item B + + can_ok($module, @methods); + can_ok($object, @methods); + +Checks to make sure the $module or $object can do these @methods +(works with functions, too). + + can_ok('Foo', qw(this that whatever)); + +is almost exactly like saying: + + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') + ); + +only without all the typing and with a better interface. Handy for +quickly testing an interface. + +No matter how many @methods you check, a single can_ok() call counts +as one test. If you desire otherwise, use: + + foreach my $meth (@methods) { + can_ok('Foo', $meth); + } + +=cut + +sub can_ok ($@) { + my($proto, @methods) = @_; + my $class = ref $proto || $proto; + + unless( @methods ) { + my $ok = $Test->ok( 0, "$class->can(...)" ); + $Test->diag(' can_ok() called with no methods'); + return $ok; + } + + my @nok = (); + foreach my $method (@methods) { + local($!, $@); # don't interfere with caller's $@ + # eval sometimes resets $! + eval { $proto->can($method) } || push @nok, $method; + } + + my $name; + $name = @methods == 1 ? "$class->can('$methods[0]')" + : "$class->can(...)"; + + my $ok = $Test->ok( !@nok, $name ); + + $Test->diag(map " $class->can('$_') failed\n", @nok); + + return $ok; +} + +=item B + + isa_ok($object, $class, $object_name); + isa_ok($ref, $type, $ref_name); + +Checks to see if the given $object->isa($class). Also checks to make +sure the object was defined in the first place. Handy for this sort +of thing: + + my $obj = Some::Module->new; + isa_ok( $obj, 'Some::Module' ); + +where you'd otherwise have to write + + my $obj = Some::Module->new; + ok( defined $obj && $obj->isa('Some::Module') ); + +to safeguard against your test script blowing up. + +It works on references, too: + + isa_ok( $array_ref, 'ARRAY' ); + +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + +=cut + +sub isa_ok ($$;$) { + my($object, $class, $obj_name) = @_; + + my $diag; + $obj_name = 'The object' unless defined $obj_name; + my $name = "$obj_name isa $class"; + if( !defined $object ) { + $diag = "$obj_name isn't defined"; + } + elsif( !ref $object ) { + $diag = "$obj_name isn't a reference"; + } + else { + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + local($@, $!); # eval sometimes resets $! + my $rslt = eval { $object->isa($class) }; + if( $@ ) { + if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { + if( !UNIVERSAL::isa($object, $class) ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } else { + die <isa on your object and got some weird error. +This should never happen. Please contact the author immediately. +Here's the error. +$@ +WHOA + } + } + elsif( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + + + + my $ok; + if( $diag ) { + $ok = $Test->ok( 0, $name ); + $Test->diag(" $diag\n"); + } + else { + $ok = $Test->ok( 1, $name ); + } + + return $ok; +} + + +=item B + +=item B + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an ok(). In this case, you can simply use pass() (to +declare the test ok) or fail (for not ok). They are synonyms for +ok(1) and ok(0). + +Use these very, very, very sparingly. + +=cut + +sub pass (;$) { + $Test->ok(1, @_); +} + +sub fail (;$) { + $Test->ok(0, @_); +} + +=back + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C. + +=over 4 + +=item B + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test (foo.t at line 52) + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C with the mnemonic C. + +B The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it it won't +interfere with the test. + +=cut + +sub diag { + $Test->diag(@_); +} + + +=back + +=head2 Module tests + +You usually want to test if the module you're testing loads ok, rather +than just vomiting if its load fails. For such purposes we have +C and C. + +=over 4 + +=item B + + BEGIN { use_ok($module); } + BEGIN { use_ok($module, @imports); } + +These simply use the given $module and test to make sure the load +happened ok. It's recommended that you run use_ok() inside a BEGIN +block so its functions are exported at compile-time and prototypes are +properly honored. + +If @imports are given, they are passed through to the use. So this: + + BEGIN { use_ok('Some::Module', qw(foo bar)) } + +is like doing this: + + use Some::Module qw(foo bar); + +don't try to do this: + + BEGIN { + use_ok('Some::Module'); + + ...some code that depends on the use... + ...happening at compile time... + } + +instead, you want: + + BEGIN { use_ok('Some::Module') } + BEGIN { ...some code that depends on the use... } + + +=cut + +sub use_ok ($;@) { + my($module, @imports) = @_; + @imports = () unless @imports; + + my $pack = caller; + + local($@,$!); # eval sometimes interferes with $! + eval <import(\@imports); +USE + + my $ok = $Test->ok( !$@, "use $module;" ); + + unless( $ok ) { + chomp $@; + $Test->diag(< + + require_ok($module); + +Like use_ok(), except it requires the $module. + +=cut + +sub require_ok ($) { + my($module) = shift; + + my $pack = caller; + + local($!, $@); # eval sometimes interferes with $! + eval <ok( !$@, "require $module;" ); + + unless( $ok ) { + chomp $@; + $Test->diag(<. + +The way Test::More handles this is with a named block. Basically, a +block of tests which can be skipped over or made todo. It's best if I +just show you... + +=over 4 + +=item B + + SKIP: { + skip $why, $how_many if $condition; + + ...normal testing code goes here... + } + +This declares a block of tests that might be skipped, $how_many tests +there are, $why and under what $condition to skip them. An example is +the easiest way to illustrate: + + SKIP: { + eval { require HTML::Lint }; + + skip "HTML::Lint not installed", 2 if $@; + + my $lint = new HTML::Lint; + isa_ok( $lint, "HTML::Lint" ); + + $lint->parse( $html ); + is( $lint->errors, 0, "No errors found in HTML" ); + } + +If the user does not have HTML::Lint installed, the whole block of +code I. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. +It's important that $how_many accurately reflects the number of tests +in the SKIP block so the # of tests run will match up with your plan. + +It's perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C, or Test::More can't work its magic. + +You don't skip tests which are failing because there's a bug in your +program, or for which you don't yet have code written. For that you +use TODO. Read on. + +=cut + +#'# +sub skip { + my($why, $how_many) = @_; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "skip() needs to know \$how_many tests are in the block" + unless $Test::Builder::No_Plan; + $how_many = 1; + } + + for( 1..$how_many ) { + $Test->skip($why); + } + + local $^W = 0; + last SKIP; +} + + +=item B + + TODO: { + local $TODO = $why if $condition; + + ...normal testing code goes here... + } + +Declares a block of tests you expect to fail and $why. Perhaps it's +because you haven't fixed a bug or haven't finished a new feature: + + TODO: { + local $TODO = "URI::Geller not finished"; + + my $card = "Eight of clubs"; + is( URI::Geller->your_card, $card, 'Is THIS your card?' ); + + my $spoon; + URI::Geller->bend_spoon; + is( $spoon, 'bent', "Spoon bending, that's original" ); + } + +With a todo block, the tests inside are expected to fail. Test::More +will run the tests normally, but print out special flags indicating +they are "todo". Test::Harness will interpret failures as being ok. +Should anything succeed, it will report it as an unexpected success. +You then know the thing you had todo is done and can remove the +TODO flag. + +The nice part about todo tests, as opposed to simply commenting out a +block of tests, is it's like having a programmatic todo list. You know +how much work is left to be done, you're aware of what bugs there are, +and you'll know immediately when they're fixed. + +Once a todo test starts succeeding, simply move it outside the block. +When the block is empty, delete it. + + +=item B + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, it's best to have the tests actually run. That way +you'll know when they start passing. Sometimes this isn't possible. +Often a failing test will cause the whole program to die or hang, even +inside an C with and using C. In these extreme +cases you have no choice but to skip over the broken tests entirely. + +The syntax and behavior is similar to a C except the +tests will be marked as failing but todo. Test::Harness will +interpret them as passing. + +=cut + +sub todo_skip { + my($why, $how_many) = @_; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "todo_skip() needs to know \$how_many tests are in the block" + unless $Test::Builder::No_Plan; + $how_many = 1; + } + + for( 1..$how_many ) { + $Test->todo_skip($why); + } + + local $^W = 0; + last TODO; +} + +=item When do I use SKIP vs. TODO? + +B, use SKIP. +This includes optional modules that aren't installed, running under +an OS that doesn't have some feature (like fork() or symlinks), or maybe +you need an Internet connection and one isn't available. + +B, use TODO. This +is for any code you haven't written yet, or bugs you have yet to fix, +but want to put tests in your testing script (always a good idea). + + +=back + +=head2 Comparison functions + +Not everything is a simple eq check or regex. There are times you +need to see if two arrays are equivalent, for instance. For these +instances, Test::More provides a handful of useful functions. + +B These are NOT well-tested on circular references. Nor am I +quite sure what will happen with filehandles. + +=over 4 + +=item B + + is_deeply( $this, $that, $test_name ); + +Similar to is(), except that if $this and $that are hash or array +references, it does a deep comparison walking each data structure to +see if they are equivalent. If the two structures are different, it +will display the place where they start differing. + +Barrie Slaymaker's Test::Differences module provides more in-depth +functionality along these lines, and it plays well with Test::More. + +B Display of scalar refs is not quite 100% + +=cut + +use vars qw(@Data_Stack); +my $DNE = bless [], 'Does::Not::Exist'; +sub is_deeply { + my($this, $that, $name) = @_; + + my $ok; + if( !ref $this || !ref $that ) { + $ok = $Test->is_eq($this, $that, $name); + } + else { + local @Data_Stack = (); + if( _deep_check($this, $that) ) { + $ok = $Test->ok(1, $name); + } + else { + $ok = $Test->ok(0, $name); + $ok = $Test->diag(_format_stack(@Data_Stack)); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vars = (); + ($vars[0] = $var) =~ s/\$FOO/ \$got/; + ($vars[1] = $var) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx (0..$#vals) { + my $val = $vals[$idx]; + $vals[$idx] = !defined $val ? 'undef' : + $val eq $DNE ? "Does not exist" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + $out =~ s/^/ /msg; + return $out; +} + + +=item B + + eq_array(\@this, \@that); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +sub eq_array { + my($a1, $a2) = @_; + return 1 if $a1 eq $a2; + + my $ok = 1; + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for (0..$max) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; + $ok = _deep_check($e1,$e2); + pop @Data_Stack if $ok; + + last unless $ok; + } + return $ok; +} + +sub _deep_check { + my($e1, $e2) = @_; + my $ok = 0; + +# my $eq; + { + # Quiet uninitialized value warnings when comparing undefs. + local $^W = 0; + + if( $e1 eq $e2 ) { + $ok = 1; + } + else { + if( UNIVERSAL::isa($e1, 'ARRAY') and + UNIVERSAL::isa($e2, 'ARRAY') ) + { + $ok = eq_array($e1, $e2); + } + elsif( UNIVERSAL::isa($e1, 'HASH') and + UNIVERSAL::isa($e2, 'HASH') ) + { + $ok = eq_hash($e1, $e2); + } + elsif( UNIVERSAL::isa($e1, 'REF') and + UNIVERSAL::isa($e2, 'REF') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + elsif( UNIVERSAL::isa($e1, 'SCALAR') and + UNIVERSAL::isa($e2, 'SCALAR') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + } + else { + push @Data_Stack, { vals => [$e1, $e2] }; + $ok = 0; + } + } + } + + return $ok; +} + + +=item B + + eq_hash(\%this, \%that); + +Determines if the two hashes contain the same keys and values. This +is a deep check. + +=cut + +sub eq_hash { + my($a1, $a2) = @_; + return 1 if $a1 eq $a2; + + my $ok = 1; + my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; + foreach my $k (keys %$bigger) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + + push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; + $ok = _deep_check($e1, $e2); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +=item B + + eq_set(\@this, \@that); + +Similar to eq_array(), except the order of the elements is B +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + +B By historical accident, this is not a true set comparision. +While the order of elements does not matter, duplicate elements do. + +=cut + +# We must make sure that references are treated neutrally. It really +# doesn't matter how we sort them, as long as both arrays are sorted +# with the same algorithm. +sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } + +sub eq_set { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + + # There's faster ways to do this, but this is easiest. + return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); +} + +=back + + +=head2 Extending and Embedding Test::More + +Sometimes the Test::More interface isn't quite enough. Fortunately, +Test::More is built on top of Test::Builder which provides a single, +unified backend for any test library to use. This means two test +libraries which both use Test::Builder B. + +If you simply want to do a little tweaking of how the tests behave, +you can access the underlying Test::Builder object like so: + +=over 4 + +=item B + + my $test_builder = Test::More->builder; + +Returns the Test::Builder object underlying Test::More for you to play +with. + +=cut + +sub builder { + return Test::Builder->new; +} + +=back + + +=head1 NOTES + +Test::More is B tested all the way back to perl 5.004. + +Test::More is thread-safe for perl 5.8.0 and up. + +=head1 BUGS and CAVEATS + +=over 4 + +=item Making your own ok() + +If you are trying to extend Test::More, don't. Use Test::Builder +instead. + +=item The eq_* family has some caveats. + +=item Test::Harness upgrades + +no_plan and todo depend on new Test::Harness features and fixes. If +you're going to distribute tests that use no_plan or todo your +end-users will have to upgrade Test::Harness to the latest one on +CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness +will work fine. + +If you simply depend on Test::More, it's own dependencies will cause a +Test::Harness upgrade. + +=back + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's Test +module. I was largely unaware of its existence when I'd first +written my own ok() routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +L 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 for more ways to test complex data structures. +And it plays well with Test::More. + +L is the old testing module. Its main benefit is that it has +been distributed with Perl since 5.004_05. + +L for details on how your test results are interpreted +by Perl. + +L describes a very featureful unit testing interface. + +L shows the idea of embedded testing. + +L is another approach to embedded testing. + + +=head1 AUTHORS + +Michael G Schwern Eschwern@pobox.comE with much inspiration +from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, chromatic and the perl-qa gang. + + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; -- cgit v1.1