diff --git a/Makefile.PL b/Makefile.PL index 715bff4..293097c 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -59,6 +59,7 @@ WriteMakefile( VERSION_FROM => 'BerkeleyDB.pm', XSPROTOARG => '-noprototypes', DEFINE => "$OS2 $WALL $TRACE", + PREREQ_PM => { 'Test-Simple' => 0 }, #'macro' => { INSTALLDIRS => 'perl' }, 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}, ($] >= 5.005 diff --git a/t/Test/Builder.pm b/t/Test/Builder.pm deleted file mode 100644 index 859915b..0000000 --- a/t/Test/Builder.pm +++ /dev/null @@ -1,1625 +0,0 @@ -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); -$VERSION = '0.30'; -$VERSION = eval $VERSION; # make the alpha version come out as a number - -# Make Test::Builder thread-safe for ithreads. -BEGIN { - use Config; - # Load threads::shared when threads are turned on - if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { - require threads::shared; - - # Hack around YET ANOTHER threads::shared bug. It would - # occassionally forget the contents of the variable when sharing it. - # So we first copy the data, then share, then put our copy back. - *share = sub (\[$@%]) { - my $type = ref $_[0]; - my $data; - - if( $type eq 'HASH' ) { - %$data = %{$_[0]}; - } - elsif( $type eq 'ARRAY' ) { - @$data = @{$_[0]}; - } - elsif( $type eq 'SCALAR' ) { - $$data = ${$_[0]}; - } - else { - die "Unknown type: ".$type; - } - - $_[0] = &threads::shared::share($_[0]); - - if( $type eq 'HASH' ) { - %{$_[0]} = %$data; - } - elsif( $type eq 'ARRAY' ) { - @{$_[0]} = @$data; - } - elsif( $type eq 'SCALAR' ) { - ${$_[0]} = $$data; - } - else { - die "Unknown type: ".$type; - } - - return $_[0]; - }; - } - # 5.8.0's threads::shared is busted when threads are off. - # We emulate it here. - else { - *share = sub { return $_[0] }; - *lock = sub { 0 }; - } -} - - -=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 C always returns the same -Test::Builder object. No matter how many times you call new(), you're -getting the same object. This is called a singleton. This is done so that -multiple modules share such global information as the test counter and -where test output is going. - -If you want a completely new Test::Builder object different from the -singleton, use C. - -=cut - -my $Test = Test::Builder->new; -sub new { - my($class) = shift; - $Test ||= $class->create; - return $Test; -} - - -=item B - - my $Test = Test::Builder->create; - -Ok, so there can be more than one Test::Builder object and this is how -you get it. You might use this instead of C if you're testing -a Test::Builder based module, but otherwise you probably want C. - -B: the implementation is not complete. C, for example, is -still shared amongst B Test::Builder objects, even ones created using -this method. Also, the method name may change in the future. - -=cut - -sub create { - my $class = shift; - - my $self = bless {}, $class; - $self->reset; - - return $self; -} - -=item B - - $Test->reset; - -Reinitializes the Test::Builder singleton to its original state. -Mostly useful for tests run in persistent environments where the same -test might be run multiple times in the same process. - -=cut - -use vars qw($Level); - -sub reset { - my ($self) = @_; - - # We leave this a global because it has to be localized and localizing - # hash keys is just asking for pain. Also, it was documented. - $Level = 1; - - $self->{Test_Died} = 0; - $self->{Have_Plan} = 0; - $self->{No_Plan} = 0; - $self->{Original_Pid} = $$; - - share($self->{Curr_Test}); - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share([]); - - $self->{Exported_To} = undef; - $self->{Expected_Tests} = 0; - - $self->{Skip_All} = 0; - - $self->{Use_Nums} = 1; - - $self->{No_Header} = 0; - $self->{No_Ending} = 0; - - $self->_dup_stdhandles unless $^C; - - return undef; -} - -=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 - -sub exported_to { - my($self, $pack) = @_; - - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{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( $self->{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 - -sub expected_tests { - my $self = shift; - my($max) = @_; - - if( @_ ) { - die "Number of tests must be a postive integer. You gave it '$max'.\n" - unless $max =~ /^\+?\d+$/ and $max > 0; - - $self->{Expected_Tests} = $max; - $self->{Have_Plan} = 1; - - $self->_print("1..$max\n") unless $self->no_header; - } - return $self->{Expected_Tests}; -} - - -=item B - - $Test->no_plan; - -Declares that this test will run an indeterminate # of tests. - -=cut - -sub no_plan { - my $self = shift; - - $self->{No_Plan} = 1; - $self->{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 { - my $self = shift; - - return($self->{Expected_Tests}) if $self->{Expected_Tests}; - return('no_plan') if $self->{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 - -sub skip_all { - my($self, $reason) = @_; - - my $out = "1..0"; - $out .= " # Skip $reason" if $reason; - $out .= "\n"; - - $self->{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( $self->{Have_Plan} ) { - require Carp; - Carp::croak("You tried to run a test without a plan! Gotta have a plan."); - } - - lock $self->{Curr_Test}; - $self->{Curr_Test}++; - - # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload(\$name); - - $self->diag(<caller; - - my $todo = $self->todo($pack); - $self->_unoverload(\$todo); - - my $out; - my $result = &share({}); - - unless( $test ) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); - } - - $out .= "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; - } - - if( $todo ) { - $out .= " # TODO $todo"; - $result->{reason} = $todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } - - $self->{Test_Results}[$self->{Curr_Test}-1] = $result; - $out .= "\n"; - - $self->_print($out); - - unless( $test ) { - my $msg = $todo ? "Failed (TODO)" : "Failed"; - $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; - $self->diag(" $msg test ($file at line $line)\n"); - } - - return $test ? 1 : 0; -} - - -sub _unoverload { - my $self = shift; - - local($@,$!); - - eval { require overload } || return; - - foreach my $thing (@_) { - eval { - if( defined $$thing ) { - if( my $string_meth = overload::Method($$thing, '""') ) { - $$thing = $$thing->$string_meth(); - } - } - }; - } -} - - -=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($got, 'ne', $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; - - return $usable_regex unless defined $regex; - - my($re, $opts); - - # Check for qr/foo/ - if( ref $regex eq 'Regexp' ) { - $usable_regex = $regex; - } - # Check for '/foo/' or 'm,foo,' - elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or - (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx - ) - { - $usable_regex = length $opts ? "(?$opts)$re" : $re; - } - - return $usable_regex; -}; - -sub _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 ||= ''; - $self->_unoverload(\$why); - - unless( $self->{Have_Plan} ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } - - lock($self->{Curr_Test}); - $self->{Curr_Test}++; - - $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ - 'ok' => 1, - actual_ok => 1, - name => '', - type => 'skip', - reason => $why, - }); - - my $out = "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # skip"; - $out .= " $why" if length $why; - $out .= "\n"; - - $self->_print($out); - - return 1; -} - - -=item B - - $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( $self->{Have_Plan} ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } - - lock($self->{Curr_Test}); - $self->{Curr_Test}++; - - $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - }); - - my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; - - $self->_print($out); - - return 1; -} - - -=begin _unimplemented - -=item B - - $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; -} - - -=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 - -sub use_numbers { - my($self, $use_nums) = @_; - - if( defined $use_nums ) { - $self->{Use_Nums} = $use_nums; - } - return $self->{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 below. - -If this is true, none of that will be done. - -=cut - -sub no_header { - my($self, $no_header) = @_; - - if( defined $no_header ) { - $self->{No_Header} = $no_header; - } - return $self->{No_Header}; -} - -sub no_ending { - my($self, $no_ending) = @_; - - if( defined $no_ending ) { - $self->{No_Ending} = $no_ending; - } - return $self->{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 @msgs. Like C, arguments are simply -appended together. - -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; - - # Smash args together like print does. - # Convert undef to 'undef' so its readable. - my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; - - # Escape each line with a #. - $msg =~ s/^/# /gm; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\Z/; - - local $Level = $Level + 1; - $self->_print_diag($msg); - - 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; - - my $msg = join '', @msgs; - - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->output; - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - $msg =~ s/\n(.)/\n# $1/sg; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\Z/; - - print $fh $msg; -} - - -=item B<_print_diag> - - $Test->_print_diag(@msg); - -Like _print, but prints to the current diagnostic filehandle. - -=cut - -sub _print_diag { - my $self = shift; - - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - print $fh @_; -} - -=item B - - $Test->output($fh); - $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 - -sub output { - my($self, $fh) = @_; - - if( defined $fh ) { - $self->{Out_FH} = _new_fh($fh); - } - return $self->{Out_FH}; -} - -sub failure_output { - my($self, $fh) = @_; - - if( defined $fh ) { - $self->{Fail_FH} = _new_fh($fh); - } - return $self->{Fail_FH}; -} - -sub todo_output { - my($self, $fh) = @_; - - if( defined $fh ) { - $self->{Todo_FH} = _new_fh($fh); - } - return $self->{Todo_FH}; -} - - -sub _new_fh { - my($file_or_fh) = shift; - - my $fh; - if( _is_fh($file_or_fh) ) { - $fh = $file_or_fh; - } - else { - $fh = do { local *FH }; - open $fh, ">$file_or_fh" or - die "Can't open test output log $file_or_fh: $!"; - _autoflush($fh); - } - - return $fh; -} - - -sub _is_fh { - my $maybe_fh = shift; - - return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob - - return UNIVERSAL::isa($maybe_fh, 'GLOB') || - UNIVERSAL::isa($maybe_fh, 'IO::Handle') || - - # 5.5.4's tied() and can() doesn't like getting undef - UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE'); -} - - -sub _autoflush { - my($fh) = shift; - my $old_fh = select $fh; - $| = 1; - select $old_fh; -} - - -sub _dup_stdhandles { - my $self = shift; - - $self->_open_testhandles; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush(\*TESTOUT); - _autoflush(\*STDOUT); - _autoflush(\*TESTERR); - _autoflush(\*STDERR); - - $self->output(\*TESTOUT); - $self->failure_output(\*TESTERR); - $self->todo_output(\*TESTOUT); -} - - -my $Opened_Testhandles = 0; -sub _open_testhandles { - return if $Opened_Testhandles; - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; - open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; - $Opened_Testhandles = 1; -} - - -=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 number we're on. You usually shouldn't -have to set this. - -If set forward, the details of the missing tests are filled in as 'unknown'. -if set backward, the details of the intervening tests are deleted. You -can erase history if you really want to. - -=cut - -sub current_test { - my($self, $num) = @_; - - lock($self->{Curr_Test}); - if( defined $num ) { - unless( $self->{Have_Plan} ) { - require Carp; - Carp::croak("Can't change the current test number without a plan!"); - } - - $self->{Curr_Test} = $num; - - # If the test counter is being pushed forward fill in the details. - my $test_results = $self->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for ($start..$num-1) { - $test_results->[$_] = &share({ - 'ok' => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - }); - } - } - # If backward, wipe history. Its their funeral. - elsif( $num < @$test_results ) { - $#{$test_results} = $num - 1; - } - } - return $self->{Curr_Test}; -} - - -=item B - - my @tests = $Test->summary; - -A simple summary of the tests so far. True for pass, false for fail. -This is a logical pass/fail, so todos are passes. - -Of course, test #1 is $tests[0], etc... - -=cut - -sub summary { - my($self) = shift; - - return map { $_->{'ok'} } @{ $self->{Test_Results} }; -} - -=item B
- - 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 { - my $self = shift; - return @{ $self->{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 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 based on $Level. - -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($Level); - return 0 unless $pack; - - 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> - - $self->_sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - my $self = shift; - - _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$self->{Have_Plan} and $self->{Curr_Test}, - 'Somehow your tests ran without a plan!'); - _whoa($self->{Curr_Test} != @{ $self->{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->{Test_Died} = 1 unless $in_eval; -}; - -sub _ending { - my $self = shift; - - $self->_sanity_check(); - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - if( ($self->{Original_Pid} != $$) or - (!$self->{Have_Plan} && !$self->{Test_Died}) ) - { - _my_exit($?); - return; - } - - # Figure out if we passed or failed and print helpful messages. - my $test_results = $self->{Test_Results}; - if( @$test_results ) { - # The plan? We have no plan. - if( $self->{No_Plan} ) { - $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; - $self->{Expected_Tests} = $self->{Curr_Test}; - } - - # Auto-extended arrays and elements which aren't explicitly - # filled in with a shared reference will puke under 5.8.0 - # ithreads. So we have to fill them in by hand. :( - my $empty_result = &share({}); - for my $idx ( 0..$self->{Expected_Tests}-1 ) { - $test_results->[$idx] = $empty_result - unless defined $test_results->[$idx]; - } - - my $num_failed = grep !$_->{'ok'}, - @{$test_results}[0..$self->{Expected_Tests}-1]; - $num_failed += abs($self->{Expected_Tests} - @$test_results); - - if( $self->{Curr_Test} < $self->{Expected_Tests} ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. -FAIL - } - elsif( $self->{Curr_Test} > $self->{Expected_Tests} ) { - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. -FAIL - } - elsif ( $num_failed ) { - my $s = $num_failed == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $self->{Expected_Tests}. -FAIL - } - - if( $self->{Test_Died} ) { - $self->diag(<<"FAIL"); -Looks like your test died just after $self->{Curr_Test}. -FAIL - - _my_exit( 255 ) && return; - } - - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; - } - elsif ( $self->{Skip_All} ) { - _my_exit( 0 ) && return; - } - elsif ( $self->{Test_Died} ) { - $self->diag(<<'FAIL'); -Looks like your test died before it could output anything. -FAIL - _my_exit( 255 ) && return; - } - else { - $self->diag("No tests run!\n"); - _my_exit( 255 ) && return; - } -} - -END { - $Test->_ending if defined $Test and !$Test->no_ending; -} - -=head1 EXIT CODES - -If all your tests passed, Test::Builder will exit with zero (which is -normal). If anything failed it will exit with how many failed. If -you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Builder -will throw a warning and exit with 255. If the test died, even after -having successfully completed all its tests, it will still be -considered a failure and will exit with 255. - -So the exit codes are... - - 0 all tests successful - 255 test died - any other number how many failed (including missing or extras) - -If you fail more than 254 tests, it will be reported as 254. - - -=head1 THREADS - -In perl 5.8.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. - -Test::Builder is only thread-aware if threads.pm is loaded I -Test::Builder. - -=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, 2004 by chromatic Echromatic@wgz.orgE and - Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1; diff --git a/t/Test/More.pm b/t/Test/More.pm deleted file mode 100644 index 51c4c26..0000000 --- a/t/Test/More.pm +++ /dev/null @@ -1,1493 +0,0 @@ -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.60'; -$VERSION = eval $VERSION; # make the alpha version come out as a number - -@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; -my $Show_Diag = 1; - - -# 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); - - # 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); - -B: using no_plan requires a Test::Harness upgrade else it will -think everything has failed. See L) - -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 $idx = 0; - my @cleaned_plan; - while( $idx <= $#plan ) { - my $item = $plan[$idx]; - - if( $item eq 'no_diag' ) { - $Show_Diag = 0; - } - else { - push @cleaned_plan, $item; - } - - $idx++; - } - - $Test->plan(@cleaned_plan); -} - -sub import { - my($class) = shift; - - my $caller = caller; - - $Test->exported_to($caller); - - my $idx = 0; - my @plan; - my @imports; - while( $idx <= $#_ ) { - my $item = $_[$idx]; - - if( $item eq 'import' ) { - push @imports, @{$_[$idx+1]}; - $idx++; - } - else { - push @plan, $item; - } - - $idx++; - } - - plan(@plan); - - __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); -} - - -=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! - is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); - -This does not check if C is true, it checks if -it returns 1. Very different. Similar caveats exist for false and 0. -In these cases, use ok(). - - ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); - -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 C<< $object->isa($class) >>. Also checks to make -sure the object was defined in the first place. Handy for this sort -of thing: - - my $obj = Some::Module->new; - isa_ok( $obj, 'Some::Module' ); - -where you'd otherwise have to write - - my $obj = Some::Module->new; - ok( defined $obj && $obj->isa('Some::Module') ); - -to safeguard against your test script blowing up. - -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. Like C @diagnostic_message is simply concatinated -together. - -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. - -All diag()s can be made silent by passing the "no_diag" option to -Test::More. C 1, 'no_diag'>. This is useful -if you have diagnostics for personal testing but then wish to make -them silent for release without commenting out each individual -statement. - -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 { - return unless $Show_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); - -Version numbers can be checked like so: - - # Just like "use Some::Module 1.02" - BEGIN { use_ok('Some::Module', 1.02) } - -Don't try to do this: - - BEGIN { - use_ok('Some::Module'); - - ...some code that depends on the use... - ...happening at compile time... - } - -because the notion of "compile-time" is relative. Instead, you want: - - BEGIN { use_ok('Some::Module') } - BEGIN { ...some code that depends on the use... } - - -=cut - -sub use_ok ($;@) { - my($module, @imports) = @_; - @imports = () unless @imports; - - my($pack,$filename,$line) = caller; - - local($@,$!); # eval sometimes interferes with $! - - if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { - # probably a version check. Perl needs to see the bare number - # for it to work with non-Exporter based modules. - eval <ok( !$@, "use $module;" ); - - unless( $ok ) { - chomp $@; - $@ =~ s{^BEGIN failed--compilation aborted at .*$} - {BEGIN failed--compilation aborted at $filename line $line.}m; - $Test->diag(< - - require_ok($module); - require_ok($file); - -Like use_ok(), except it requires the $module or $file. - -=cut - -sub require_ok ($) { - my($module) = shift; - - my $pack = caller; - - # Try to deterine if we've been given a module name or file. - # Module names must be barewords, files not. - $module = qq['$module'] unless _is_module_name($module); - - 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. -If your plan is C $how_many is optional and will default to 1. - -It's perfectly safe to nest SKIP blocks. Each SKIP block must have -the label C, or Test::More can't work its magic. - -You don't skip tests which are failing because there's a bug in your -program, or for which you don't yet have code written. For that you -use TODO. Read on. - -=cut - -#'# -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->has_plan eq '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. - -B: TODO tests require a Test::Harness upgrade else it will -treat it as a normal failure. See L) - - -=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->has_plan eq '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 Complex data structures - -Not everything is a simple eq check or regex. There are times you -need to see if two data structures are equivalent. For these -instances Test::More provides a handful of useful functions. - -B I'm not 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. - -Test::Differences and Test::Deep provide more in-depth functionality -along these lines. - -=back - -=cut - -use vars qw(@Data_Stack %Refs_Seen); -my $DNE = bless [], 'Does::Not::Exist'; -sub is_deeply { - unless( @_ == 2 or @_ == 3 ) { - my $msg = <ok(0); - } - - my($this, $that, $name) = @_; - - my $ok; - if( !ref $this and !ref $that ) { # neither is a reference - $ok = $Test->is_eq($this, $that, $name); - } - elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't - $ok = $Test->ok(0, $name); - $Test->diag( _format_stack({ vals => [ $this, $that ] }) ); - } - else { # both references - local @Data_Stack = (); - if( _deep_check($this, $that) ) { - $ok = $Test->ok(1, $name); - } - else { - $ok = $Test->ok(0, $name); - $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" : - ref $val ? "$val" : - "'$val'"; - } - - $out .= "$vars[0] = $vals[0]\n"; - $out .= "$vars[1] = $vals[1]\n"; - - $out =~ s/^/ /msg; - return $out; -} - - -sub _type { - my $thing = shift; - - return '' if !ref $thing; - - for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) { - return $type if UNIVERSAL::isa($thing, $type); - } - - return ''; -} - - -=head2 Discouraged comparison functions - -The use of the following functions is discouraged as they are not -actually testing functions and produce no diagnostics to help figure -out what went wrong. They were written before is_deeply() existed -because I couldn't figure out how to display a useful diff of two -arbitrary data structures. - -These functions are usually used inside an ok(). - - ok( eq_array(\@this, \@that) ); - -C can do that better and with diagnostics. - - is_deeply( \@this, \@that ); - -They may be deprecated in future versions. - -=over 4 - -=item B - - my $is_eq = 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 { - local @Data_Stack; - _deep_check(@_); -} - -sub _eq_array { - my($a1, $a2) = @_; - - if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { - warn "eq_array passed a non-array ref"; - return 0; - } - - return 1 if $a1 eq $a2; - - my $ok = 1; - my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; - for (0..$max) { - my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; - my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; - - push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; - $ok = _deep_check($e1,$e2); - pop @Data_Stack if $ok; - - last unless $ok; - } - - return $ok; -} - -sub _deep_check { - my($e1, $e2) = @_; - my $ok = 0; - - # Effectively turn %Refs_Seen into a stack. This avoids picking up - # the same referenced used twice (such as [\$a, \$a]) to be considered - # circular. - local %Refs_Seen = %Refs_Seen; - - { - # Quiet uninitialized value warnings when comparing undefs. - local $^W = 0; - - $Test->_unoverload(\$e1, \$e2); - - # Either they're both references or both not. - my $same_ref = !(!ref $e1 xor !ref $e2); - my $not_ref = (!ref $e1 and !ref $e2); - - if( defined $e1 xor defined $e2 ) { - $ok = 0; - } - elsif ( $e1 == $DNE xor $e2 == $DNE ) { - $ok = 0; - } - elsif ( $same_ref and ($e1 eq $e2) ) { - $ok = 1; - } - elsif ( $not_ref ) { - push @Data_Stack, { type => '', vals => [$e1, $e2] }; - $ok = 0; - } - else { - if( $Refs_Seen{$e1} ) { - return $Refs_Seen{$e1} eq $e2; - } - else { - $Refs_Seen{$e1} = "$e2"; - } - - my $type = _type($e1); - $type = 'DIFFERENT' unless _type($e2) eq $type; - - if( $type eq 'DIFFERENT' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; - $ok = 0; - } - elsif( $type eq 'ARRAY' ) { - $ok = _eq_array($e1, $e2); - } - elsif( $type eq 'HASH' ) { - $ok = _eq_hash($e1, $e2); - } - elsif( $type eq 'REF' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); - pop @Data_Stack if $ok; - } - elsif( $type eq 'SCALAR' ) { - push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); - pop @Data_Stack if $ok; - } - else { - _whoa(1, "No type in _deep_check"); - } - } - } - - return $ok; -} - - -sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die < - - my $is_eq = eq_hash(\%this, \%that); - -Determines if the two hashes contain the same keys and values. This -is a deep check. - -=cut - -sub eq_hash { - local @Data_Stack; - return _deep_check(@_); -} - -sub _eq_hash { - my($a1, $a2) = @_; - - if( grep !_type($_) eq 'HASH', $a1, $a2 ) { - warn "eq_hash passed a non-hash ref"; - return 0; - } - - return 1 if $a1 eq $a2; - - my $ok = 1; - my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - foreach my $k (keys %$bigger) { - my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; - my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; - - push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; - $ok = _deep_check($e1, $e2); - pop @Data_Stack if $ok; - - last unless $ok; - } - - return $ok; -} - -=item B - - my $is_eq = 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. - - ok( eq_set(\@this, \@that) ); - -Is better written: - - is_deeply( [sort @this], [sort @that] ); - -B By historical accident, this is not a true set comparision. -While the order of elements does not matter, duplicate elements do. - -Test::Deep contains much better set comparison functions. - -=cut - -sub eq_set { - my($a1, $a2) = @_; - return 0 unless @$a1 == @$a2; - - # There's faster ways to do this, but this is easiest. - local $^W = 0; - - # 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. - # Have to inline the sort routine due to a threading/sort bug. - # See [rt.cpan.org 6782] - return eq_array( - [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1], - [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$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 EXIT CODES - -If all your tests passed, Test::Builder will exit with zero (which is -normal). If anything failed it will exit with how many failed. If -you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Builder -will throw a warning and exit with 255. If the test died, even after -having successfully completed all its tests, it will still be -considered a failure and will exit with 255. - -So the exit codes are... - - 0 all tests successful - 255 test died - any other number how many failed (including missing or extras) - -If you fail more than 254 tests, it will be reported as 254. - -B This behavior may go away in future versions. - - -=head1 CAVEATS and NOTES - -=over 4 - -=item Backwards compatibility - -Test::More works with Perls as old as 5.004_05. - - -=item Overloaded objects - -String overloaded objects are compared B. This prevents -Test::More from piercing an object's interface allowing better blackbox -testing. So if a function starts returning overloaded objects instead of -bare strings your tests won't notice the difference. This is good. - -However, it does mean that functions like is_deeply() cannot be used to -test the internals of string overloaded objects. In this case I would -suggest Test::Deep which contains more flexible testing functions for -complex data structures. - - -=item Threads - -Test::More will only be aware of threads if "use threads" has been done -I Test::More is loaded. This is ok: - - use threads; - use Test::More; - -This may cause problems: - - use Test::More - use threads; - - -=item Test::Harness upgrade - -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. - -Installing Test::More should also upgrade Test::Harness. - -=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 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 for more ways to test complex data structures. -And it plays well with Test::More. - -L is like XUnit but more perlish. - -L gives you more powerful complex data structure testing. - -L is XUnit style testing. - -L shows the idea of embedded testing. - -L installs a whole bunch of useful test modules. - - -=head1 AUTHORS - -Michael G Schwern Eschwern@pobox.comE with much inspiration -from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and -the perl-qa gang. - - -=head1 BUGS - -See F to report and view bugs. - - -=head1 COPYRIGHT - -Copyright 2001, 2002, 2004 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;