diff -up perl-5.8.8/lib/Test/More.pm.crr perl-5.8.8/lib/Test/More.pm
--- perl-5.8.8/lib/Test/More.pm.crr 2005-10-08 08:56:17.000000000 +0200
+++ perl-5.8.8/lib/Test/More.pm 2008-02-27 11:01:46.000000000 +0100
@@ -1,7 +1,6 @@
package Test::More;
-use 5.004;
-
+use 5.006;
use strict;
@@ -16,7 +15,7 @@ sub _carp {
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.62';
+$VERSION = '0.78';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -31,7 +30,7 @@ use Test::Builder::Module;
plan
can_ok isa_ok
diag
- BAIL_OUT
+ BAIL_OUT
);
@@ -41,7 +40,7 @@ Test::More - yet another framework for w
=head1 SYNOPSIS
- use Test::More tests => $Num_Tests;
+ use Test::More tests => 23;
# or
use Test::More qw(no_plan);
# or
@@ -51,20 +50,20 @@ Test::More - yet another framework for w
require_ok( 'Some::Module' );
# Various ways to say "ok"
- ok($this eq $that, $test_name);
+ ok($got eq $expected, $test_name);
- is ($this, $that, $test_name);
- isnt($this, $that, $test_name);
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
# Rather than print STDERR "# here's what went wrong\n"
diag("here's what went wrong");
- like ($this, qr/that/, $test_name);
- unlike($this, qr/that/, $test_name);
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
- cmp_ok($this, '==', $that, $test_name);
+ cmp_ok($got, '==', $expected, $test_name);
- is_deeply($complex_structure1, $complex_structure2, $test_name);
+ is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
SKIP: {
skip $why, $how_many unless $have_some_feature;
@@ -113,7 +112,7 @@ failure.
The preferred way to do this is to declare a plan when you C<use Test::More>.
- use Test::More tests => $Num_Tests;
+ use Test::More tests => 23;
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
@@ -226,9 +225,9 @@ respectively.
=item B<ok>
- ok($this eq $that, $test_name);
+ ok($got eq $expected, $test_name);
-This simply evaluates any expression (C<$this eq $that> is just a
+This simply evaluates any expression (C<$got eq $expected> is just a
simple example) and uses that to determine if the test succeeded or
failed. A true expression passes, a false one fails. Very simple.
@@ -252,7 +251,7 @@ Should an ok() fail, it will produce som
# Failed test 'sufficient mucus'
# in foo.t at line 42.
-This is actually Test::Simple's ok() routine.
+This is the same as Test::Simple's ok() routine.
=cut
@@ -267,8 +266,8 @@ sub ok ($;$) {
=item B<isnt>
- is ( $this, $that, $test_name );
- isnt( $this, $that, $test_name );
+ is ( $got, $expected, $test_name );
+ isnt( $got, $expected, $test_name );
Similar to ok(), is() and isnt() compare their two arguments
with C<eq> and C<ne> respectively and use the result of that to
@@ -340,17 +339,17 @@ sub isnt ($$;$) {
=item B<like>
- like( $this, qr/that/, $test_name );
+ like( $got, qr/expected/, $test_name );
-Similar to ok(), like() matches $this against the regex C<qr/that/>.
+Similar to ok(), like() matches $got against the regex C<qr/expected/>.
So this:
- like($this, qr/that/, 'this is like that');
+ like($got, qr/expected/, 'this is like that');
is similar to:
- ok( $this =~ /that/, 'this is like that');
+ ok( $got =~ /expected/, 'this is like that');
(Mnemonic "This is like that".)
@@ -359,9 +358,9 @@ regex reference (i.e. C<qr//>) or (for b
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):
- like( $this, '/that/', 'this is like that' );
+ like( $got, '/expected/', 'this is like that' );
-Regex options may be placed on the end (C<'/that/i'>).
+Regex options may be placed on the end (C<'/expected/i'>).
Its advantages over ok() are similar to that of is() and isnt(). Better
diagnostics on failure.
@@ -377,9 +376,9 @@ sub like ($$;$) {
=item B<unlike>
- unlike( $this, qr/that/, $test_name );
+ unlike( $got, qr/expected/, $test_name );
-Works exactly as like(), only it checks if $this B<does not> match the
+Works exactly as like(), only it checks if $got B<does not> match the
given pattern.
=cut
@@ -393,23 +392,23 @@ sub unlike ($$;$) {
=item B<cmp_ok>
- cmp_ok( $this, $op, $that, $test_name );
+ cmp_ok( $got, $op, $expected, $test_name );
Halfway between ok() and is() lies cmp_ok(). This allows you to
compare two arguments using any binary perl operator.
- # ok( $this eq $that );
- cmp_ok( $this, 'eq', $that, 'this eq that' );
+ # ok( $got eq $expected );
+ cmp_ok( $got, 'eq', $expected, 'this eq that' );
- # ok( $this == $that );
- cmp_ok( $this, '==', $that, 'this == that' );
+ # ok( $got == $expected );
+ cmp_ok( $got, '==', $expected, 'this == that' );
- # ok( $this && $that );
- cmp_ok( $this, '&&', $that, 'this && that' );
+ # ok( $got && $expected );
+ cmp_ok( $got, '&&', $expected, 'this && that' );
...etc...
-Its advantage over ok() is when the test fails you'll know what $this
-and $that were:
+Its advantage over ok() is when the test fails you'll know what $got
+and $expected were:
not ok 1
# Failed test in foo.t at line 12.
@@ -465,6 +464,12 @@ sub can_ok ($@) {
my $class = ref $proto || $proto;
my $tb = Test::More->builder;
+ unless( $class ) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
unless( @methods ) {
my $ok = $tb->ok( 0, "$class->can(...)" );
$tb->diag(' can_ok() called with no methods');
@@ -473,15 +478,13 @@ sub can_ok ($@) {
my @nok = ();
foreach my $method (@methods) {
- local($!, $@); # don't interfere with caller's $@
- # eval sometimes resets $!
- eval { $proto->can($method) } || push @nok, $method;
+ $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
-
+
my $ok = $tb->ok( !@nok, $name );
$tb->diag(map " $class->can('$_') failed\n", @nok);
@@ -533,10 +536,10 @@ sub isa_ok ($$;$) {
}
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/ ) {
+ my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
+ if( $error ) {
+ if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+ # Its an unblessed reference
if( !UNIVERSAL::isa($object, $class) ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
@@ -544,9 +547,8 @@ sub isa_ok ($$;$) {
} else {
die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
-This should never happen. Please contact the author immediately.
Here's the error.
-$@
+$error
WHOA
}
}
@@ -656,32 +658,35 @@ sub use_ok ($;@) {
my($pack,$filename,$line) = caller;
- local($@,$!); # eval sometimes interferes with $!
-
+ my $code;
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
# probably a version check. Perl needs to see the bare number
# for it to work with non-Exporter based modules.
- eval <<USE;
+ $code = <<USE;
package $pack;
use $module $imports[0];
+1;
USE
}
else {
- eval <<USE;
+ $code = <<USE;
package $pack;
-use $module \@imports;
+use $module \@{\$args[0]};
+1;
USE
}
- my $ok = $tb->ok( !$@, "use $module;" );
+ my($eval_result, $eval_error) = _eval($code, \@imports);
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
unless( $ok ) {
- chomp $@;
+ chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at $filename line $line.}m;
$tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
- Error: $@
+ Error: $eval_error
DIAGNOSTIC
}
@@ -689,6 +694,20 @@ DIAGNOSTIC
return $ok;
}
+
+sub _eval {
+ my($code) = shift;
+ my @args = @_;
+
+ # Work around oddities surrounding resetting of $@ by immediately
+ # storing it.
+ local($@,$!,$SIG{__DIE__}); # isolate eval
+ my $eval_result = eval $code;
+ my $eval_error = $@;
+
+ return($eval_result, $eval_error);
+}
+
=item B<require_ok>
require_ok($module);
@@ -708,19 +727,20 @@ sub require_ok ($) {
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
- local($!, $@); # eval sometimes interferes with $!
- eval <<REQUIRE;
+ my $code = <<REQUIRE;
package $pack;
require $module;
+1;
REQUIRE
- my $ok = $tb->ok( !$@, "require $module;" );
+ my($eval_result, $eval_error) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
unless( $ok ) {
- chomp $@;
+ chomp $eval_error;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
- Error: $@
+ Error: $eval_error
DIAGNOSTIC
}
@@ -754,9 +774,9 @@ B<NOTE> I'm not quite sure what will hap
=item B<is_deeply>
- is_deeply( $this, $that, $test_name );
+ is_deeply( $got, $expected, $test_name );
-Similar to is(), except that if $this and $that are references, it
+Similar to is(), except that if $got and $expected are references, it
does a deep comparison walking each data structure to see if they are
equivalent. If the two structures are different, it will display the
place where they start differing.
@@ -776,6 +796,12 @@ along these lines.
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
+
+sub _dne {
+ ref $_[0] eq ref $DNE;
+}
+
+
sub is_deeply {
my $tb = Test::More->builder;
@@ -792,21 +818,21 @@ WARNING
return $tb->ok(0);
}
- my($this, $that, $name) = @_;
+ my($got, $expected, $name) = @_;
- $tb->_unoverload_str(\$that, \$this);
+ $tb->_unoverload_str(\$expected, \$got);
my $ok;
- if( !ref $this and !ref $that ) { # neither is a reference
- $ok = $tb->is_eq($this, $that, $name);
+ if( !ref $got and !ref $expected ) { # neither is a reference
+ $ok = $tb->is_eq($got, $expected, $name);
}
- elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
+ elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
$ok = $tb->ok(0, $name);
- $tb->diag( _format_stack({ vals => [ $this, $that ] }) );
+ $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
}
else { # both references
local @Data_Stack = ();
- if( _deep_check($this, $that) ) {
+ if( _deep_check($got, $expected) ) {
$ok = $tb->ok(1, $name);
}
else {
@@ -848,8 +874,8 @@ sub _format_stack {
foreach my $idx (0..$#vals) {
my $val = $vals[$idx];
$vals[$idx] = !defined $val ? 'undef' :
- $val eq $DNE ? "Does not exist" :
- ref $val ? "$val" :
+ _dne($val) ? "Does not exist" :
+ ref $val ? "$val" :
"'$val'";
}
@@ -995,6 +1021,11 @@ sub skip {
$how_many = 1;
}
+ if( defined $how_many and $how_many =~ /\D/ ) {
+ _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
for( 1..$how_many ) {
$tb->skip($why);
}
@@ -1107,7 +1138,7 @@ but want to put tests in your testing sc
BAIL_OUT($reason);
-Incidates to the harness that things are going so badly all testing
+Indicates to the harness that things are going so badly all testing
should terminate. This includes the running any additional test scripts.
This is typically used when testing cannot continue such as a critical
@@ -1138,11 +1169,11 @@ arbitrary data structures.
These functions are usually used inside an ok().
- ok( eq_array(\@this, \@that) );
+ ok( eq_array(\@got, \@expected) );
C<is_deeply()> can do that better and with diagnostics.
- is_deeply( \@this, \@that );
+ is_deeply( \@got, \@expected );
They may be deprecated in future versions.
@@ -1150,7 +1181,7 @@ They may be deprecated in future version
=item B<eq_array>
- my $is_eq = eq_array(\@this, \@that);
+ my $is_eq = eq_array(\@got, \@expected);
Checks if two arrays are equivalent. This is a deep check, so
multi-level structures are handled correctly.
@@ -1213,7 +1244,7 @@ sub _deep_check {
if( defined $e1 xor defined $e2 ) {
$ok = 0;
}
- elsif ( $e1 == $DNE xor $e2 == $DNE ) {
+ elsif ( _dne($e1) xor _dne($e2) ) {
$ok = 0;
}
elsif ( $same_ref and ($e1 eq $e2) ) {
@@ -1281,7 +1312,7 @@ WHOA
=item B<eq_hash>
- my $is_eq = eq_hash(\%this, \%that);
+ my $is_eq = eq_hash(\%got, \%expected);
Determines if the two hashes contain the same keys and values. This
is a deep check.
@@ -1321,17 +1352,17 @@ sub _eq_hash {
=item B<eq_set>
- my $is_eq = eq_set(\@this, \@that);
+ my $is_eq = eq_set(\@got, \@expected);
Similar to eq_array(), except the order of the elements is B<not>
important. This is a deep check, but the irrelevancy of order only
applies to the top level.
- ok( eq_set(\@this, \@that) );
+ ok( eq_set(\@got, \@expected) );
Is better written:
- is_deeply( [sort @this], [sort @that] );
+ is_deeply( [sort @got], [sort @expected] );
B<NOTE> By historical accident, this is not a true set comparison.
While the order of elements does not matter, duplicate elements do.
@@ -1423,7 +1454,7 @@ B<NOTE> This behavior may go away in fu
=item Backwards compatibility
-Test::More works with Perls as old as 5.004_05.
+Test::More works with Perls as old as 5.6.0.
=item Overloaded objects
@@ -1454,6 +1485,8 @@ This may cause problems:
use Test::More
use threads;
+5.8.1 and above are supported. Anything below that has too many bugs.
+
=item Test::Harness upgrade
@@ -1524,9 +1557,9 @@ See F<http://rt.cpan.org> to report and
=head1 COPYRIGHT
-Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-This program is free software; you can redistribute it and/or
+This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
diff -up perl-5.8.8/lib/Test/Tutorial.pod.crr perl-5.8.8/lib/Test/Tutorial.pod
diff -up perl-5.8.8/lib/Test/Builder.pm.crr perl-5.8.8/lib/Test/Builder.pm
--- perl-5.8.8/lib/Test/Builder.pm.crr 2005-10-08 10:02:05.000000000 +0200
+++ perl-5.8.8/lib/Test/Builder.pm 2008-02-27 11:01:46.000000000 +0100
@@ -1,21 +1,17 @@
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 5.006;
use strict;
-use vars qw($VERSION);
-$VERSION = '0.32';
-$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+our $VERSION = '0.78';
+$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'}) {
+ # Load threads::shared when threads are turned on.
+ # 5.8.0's threads are so busted we no longer support them.
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
@@ -35,7 +31,7 @@ BEGIN {
$$data = ${$_[0]};
}
else {
- die "Unknown type: ".$type;
+ die("Unknown type: ".$type);
}
$_[0] = &threads::shared::share($_[0]);
@@ -50,14 +46,14 @@ BEGIN {
${$_[0]} = $$data;
}
else {
- die "Unknown type: ".$type;
+ die("Unknown type: ".$type);
}
return $_[0];
};
}
- # 5.8.0's threads::shared is busted when threads are off.
- # We emulate it here.
+ # 5.8.0's threads::shared is busted when threads are off
+ # and earlier Perls just don't have that module at all.
else {
*share = sub { return $_[0] };
*lock = sub { 0 };
@@ -72,28 +68,15 @@ Test::Builder - Backend for building tes
=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;
+ use base 'Test::Builder::Module';
- $Test->exported_to($pack);
- $Test->plan(@_);
-
- $self->export_to_level(1, $self, 'ok');
- }
+ my $CLASS = __PACKAGE__;
sub ok {
my($test, $name) = @_;
+ my $tb = $CLASS->builder;
- $Test->ok($test, $name);
+ $tb->ok($test, $name);
}
@@ -176,7 +159,6 @@ sub reset {
# 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} = $$;
@@ -195,9 +177,11 @@ sub reset {
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
+ $self->{TODO} = undef;
+
$self->_dup_stdhandles unless $^C;
- return undef;
+ return;
}
=back
@@ -209,25 +193,6 @@ are. You usually only want to call one
=over 4
-=item B<exported_to>
-
- 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<plan>
$Test->plan('no_plan');
@@ -246,9 +211,10 @@ sub plan {
return unless $cmd;
+ local $Level = $Level + 1;
+
if( $self->{Have_Plan} ) {
- die sprintf "You tried to plan twice! Second plan at %s line %d\n",
- ($self->caller)[1,2];
+ $self->croak("You tried to plan twice");
}
if( $cmd eq 'no_plan' ) {
@@ -259,20 +225,19 @@ sub plan {
}
elsif( $cmd eq 'tests' ) {
if( $arg ) {
+ local $Level = $Level + 1;
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";
+ $self->croak("Got an undefined number of tests");
}
elsif( !$arg ) {
- die "You said to run 0 tests! You've got to run something.\n";
+ $self->croak("You said to run 0 tests");
}
}
else {
- require Carp;
my @args = grep { defined } ($cmd, $arg);
- Carp::croak("plan() doesn't understand @args");
+ $self->croak("plan() doesn't understand @args");
}
return 1;
@@ -293,7 +258,7 @@ sub expected_tests {
my($max) = @_;
if( @_ ) {
- die "Number of tests must be a postive integer. You gave it '$max'.\n"
+ $self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
@@ -359,12 +324,36 @@ sub skip_all {
exit(0);
}
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
+
+=cut
+
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
=back
=head2 Running tests
-These actually run the tests, analogous to the functions in
-Test::More.
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
$name is always optional.
@@ -386,10 +375,7 @@ sub ok {
# 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.");
- }
+ $self->_plan_check;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
@@ -402,9 +388,12 @@ sub ok {
Very confusing.
ERR
- my($pack, $file, $line) = $self->caller;
+ my $todo = $self->todo();
+
+ # Capture the value of $TODO for the rest of this ok() call
+ # so it can more easily be found by other routines.
+ local $self->{TODO} = $todo;
- my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
@@ -449,13 +438,14 @@ ERR
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ in $file at line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test in $file at line $line.\n]);
- }
+ my(undef, $file, $line) = $self->caller;
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
}
return $test ? 1 : 0;
@@ -466,26 +456,22 @@ sub _unoverload {
my $self = shift;
my $type = shift;
- local($@,$!);
-
- eval { require overload } || return;
+ $self->_try(sub { require overload } ) || return;
foreach my $thing (@_) {
- eval {
- if( _is_object($$thing) ) {
- if( my $string_meth = overload::Method($$thing, $type) ) {
- $$thing = $$thing->$string_meth();
- }
+ if( $self->_is_object($$thing) ) {
+ if( my $string_meth = overload::Method($$thing, $type) ) {
+ $$thing = $$thing->$string_meth();
}
- };
+ }
}
}
sub _is_object {
- my $thing = shift;
+ my($self, $thing) = @_;
- return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
+ return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
}
@@ -589,6 +575,7 @@ sub _is_diag {
}
}
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
@@ -605,7 +592,7 @@ the string version.
=item B<isnt_num>
- $Test->is_num($got, $dont_expect, $name);
+ $Test->isnt_num($got, $dont_expect, $name);
Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
the numeric version.
@@ -678,97 +665,6 @@ sub unlike {
$self->_regex_ok($this, $regex, '!~', $name);
}
-=item B<maybe_regex>
-
- $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) = @_;
-
- 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;
- }
-
- {
- my $test;
- my $code = $self->_caller_context;
-
- local($@, $!);
-
- # Yes, it has to look like this or 5.4.5 won't see the #line directive.
- # Don't ask me, man, I just work here.
- $test = eval "
-$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
-
- $test = !$test if $cmp eq '!~';
-
- local $Level = $Level + 1;
- $ok = $self->ok( $test, $name );
- }
-
- unless( $ok ) {
- $this = defined $this ? "'$this'" : 'undef';
- my $match = $cmp eq '=~' ? "doesn't match" : "matches";
- $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
- %s
- %13s '%s'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
=item B<cmp_ok>
@@ -797,12 +693,12 @@ sub cmp_ok {
my $test;
{
- local($@,$!); # don't interfere with $@
- # eval() sometimes resets $!
+ local($@,$!,$SIG{__DIE__}); # isolate eval
my $code = $self->_caller_context;
- # Yes, it has to look like this or 5.4.5 won't see the #line directive.
+ # Yes, it has to look like this or 5.4.5 won't see the #line
+ # directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
@@ -827,6 +723,8 @@ sub _cmp_diag {
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
@@ -846,6 +744,14 @@ sub _caller_context {
return $code;
}
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
=item B<BAIL_OUT>
@@ -889,10 +795,7 @@ sub skip {
$why ||= '';
$self->_unoverload_str(\$why);
- unless( $self->{Have_Plan} ) {
- require Carp;
- Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
- }
+ $self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
@@ -933,10 +836,7 @@ 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.");
- }
+ $self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
@@ -977,8 +877,179 @@ test.
=back
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+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( _is_qr($regex) ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+
+sub _is_qr {
+ my $regex = shift;
+
+ # is_regexp() checks for regexes in a robust manner, say if they're
+ # blessed.
+ return re::is_regexp($regex) if defined &re::is_regexp;
+ return ref $regex eq 'Regexp';
+}
+
+
+sub _regex_ok {
+ my($self, $this, $regex, $cmp, $name) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless (defined $usable_regex) {
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ my $test;
+ my $code = $self->_caller_context;
+
+ local($@, $!, $SIG{__DIE__}); # isolate eval
+
+ # Yes, it has to look like this or 5.4.5 won't see the #line
+ # directive.
+ # Don't ask me, man, I just work here.
+ $test = eval "
+$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless( $ok ) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+
+ local $Level = $Level + 1;
+ $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+
+# I'm not ready to publish this. It doesn't deal with array return
+# values from the code or context.
+
+=begin private
+
+=item B<_try>
+
+ my $return_from_code = $Test->try(sub { code });
+ my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
+
+$error is what would normally be in $@.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+ my($self, $code) = @_;
+
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ my $return = eval { $code->() };
+
+ return wantarray ? ($return, $@) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+ my $is_fh = $Test->is_fh($thing);
+
+Determines if the given $thing can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ # 5.5.4's tied() and can() doesn't like getting undef
+ eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
+}
+
+
+=back
+
+
=head2 Test style
+
=over 4
=item B<level>
@@ -990,14 +1061,18 @@ test failed.
Defaults to 1.
-Setting $Test::Builder::Level overrides. This is typically useful
+Setting L<$Test::Builder::Level> overrides. This is typically useful
localized:
- {
- local $Test::Builder::Level = 2;
- $Test->ok($test);
+ sub my_ok {
+ my $test = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
}
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
=cut
sub level {
@@ -1029,8 +1104,6 @@ or this if false
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
@@ -1081,7 +1154,7 @@ foreach my $attribute (qw(No_Header No_E
return $self->{$attribute};
};
- no strict 'refs';
+ no strict 'refs'; ## no critic
*{__PACKAGE__.'::'.$method} = $code;
}
@@ -1182,6 +1255,7 @@ sub _print {
print $fh $msg;
}
+=begin private
=item B<_print_diag>
@@ -1189,6 +1263,8 @@ sub _print {
Like _print, but prints to the current diagnostic filehandle.
+=end private
+
=cut
sub _print_diag {
@@ -1232,7 +1308,7 @@ sub output {
my($self, $fh) = @_;
if( defined $fh ) {
- $self->{Out_FH} = _new_fh($fh);
+ $self->{Out_FH} = $self->_new_fh($fh);
}
return $self->{Out_FH};
}
@@ -1241,7 +1317,7 @@ sub failure_output {
my($self, $fh) = @_;
if( defined $fh ) {
- $self->{Fail_FH} = _new_fh($fh);
+ $self->{Fail_FH} = $self->_new_fh($fh);
}
return $self->{Fail_FH};
}
@@ -1250,44 +1326,30 @@ sub todo_output {
my($self, $fh) = @_;
if( defined $fh ) {
- $self->{Todo_FH} = _new_fh($fh);
+ $self->{Todo_FH} = $self->_new_fh($fh);
}
return $self->{Todo_FH};
}
sub _new_fh {
+ my $self = shift;
my($file_or_fh) = shift;
my $fh;
- if( _is_fh($file_or_fh) ) {
+ if( $self->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);
+ open $fh, ">", $file_or_fh or
+ $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
}
return $fh;
}
-sub _is_fh {
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
-
- 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;
@@ -1296,6 +1358,7 @@ sub _autoflush {
}
+my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
@@ -1303,28 +1366,89 @@ sub _dup_stdhandles {
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
- _autoflush(\*TESTOUT);
+ _autoflush($Testout);
_autoflush(\*STDOUT);
- _autoflush(\*TESTERR);
+ _autoflush($Testerr);
_autoflush(\*STDERR);
- $self->output(\*TESTOUT);
- $self->failure_output(\*TESTERR);
- $self->todo_output(\*TESTOUT);
+ $self->output ($Testout);
+ $self->failure_output($Testerr);
+ $self->todo_output ($Testout);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
+ my $self = shift;
+
return if $Opened_Testhandles;
+
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
- open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
- open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
+ open( $Testout, ">&STDOUT") or die "Can't dup STDOUT: $!";
+ open( $Testerr, ">&STDERR") or die "Can't dup STDERR: $!";
+
+# $self->_copy_io_layers( \*STDOUT, $Testout );
+# $self->_copy_io_layers( \*STDERR, $Testerr );
+
$Opened_Testhandles = 1;
}
+sub _copy_io_layers {
+ my($self, $src, $dest) = @_;
+
+ $self->_try(sub {
+ require PerlIO;
+ my @layers = PerlIO::get_layers($src);
+
+ binmode $dest, join " ", map ":$_", @layers if @layers;
+ });
+}
+
+=item carp
+
+ $tb->carp(@message);
+
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<$tb->caller>).
+
+=item croak
+
+ $tb->croak(@message);
+
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<$tb->caller>).
+
+=cut
+
+sub _message_at_caller {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my($pack, $file, $line) = $self->caller;
+ return join("", @_) . " at $file line $line.\n";
+}
+
+sub carp {
+ my $self = shift;
+ warn $self->_message_at_caller(@_);
+}
+
+sub croak {
+ my $self = shift;
+ die $self->_message_at_caller(@_);
+}
+
+sub _plan_check {
+ my $self = shift;
+
+ unless( $self->{Have_Plan} ) {
+ local $Level = $Level + 2;
+ $self->croak("You tried to run a test without a plan");
+ }
+}
+
=back
@@ -1352,8 +1476,7 @@ sub current_test {
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->croak("Can't change the current test number without a plan!");
}
$self->{Curr_Test} = $num;
@@ -1462,9 +1585,10 @@ will be considered 'todo' (see Test::Mor
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.
+todo() is about finding the right package to look for $TODO in. It's
+pretty good at guessing the right package to look at. It first looks for
+the caller based on C<$Level + 1>, since C<todo()> is usually called inside
+a test function. As a last resort it will use C<exported_to()>.
Sometimes there is some confusion about where todo() should be looking
for the $TODO variable. If you want to be sure, tell it explicitly
@@ -1475,10 +1599,12 @@ what $pack to use.
sub todo {
my($self, $pack) = @_;
- $pack = $pack || $self->exported_to || $self->caller($Level);
+ return $self->{TODO} if defined $self->{TODO};
+
+ $pack = $pack || $self->caller(1) || $self->exported_to;
return 0 unless $pack;
- no strict 'refs';
+ no strict 'refs'; ## no critic
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
@@ -1491,6 +1617,8 @@ sub todo {
Like the normal caller(), except it reports according to your level().
+C<$height> will be added to the level().
+
=cut
sub caller {
@@ -1523,16 +1651,16 @@ error message.
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},
+ $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
+ $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
'Somehow your tests ran without a plan!');
- _whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
+ $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!');
}
=item B<_whoa>
- _whoa($check, $description);
+ $self->_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
@@ -1541,9 +1669,10 @@ a note to contact the author.
=cut
sub _whoa {
- my($check, $desc) = @_;
+ my($self, $check, $desc) = @_;
if( $check ) {
- die <<WHOA;
+ local $Level = $Level + 1;
+ $self->croak(<<"WHOA");
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
@@ -1574,35 +1703,27 @@ sub _my_exit {
=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;
+ my $real_exit_code = $?;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
+ if( $self->{Original_Pid} != $$ ) {
+ return;
+ }
+
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
+ if( !$self->{Have_Plan} ) {
+ return;
+ }
+
# Don't do an ending if we bailed out.
- if( ($self->{Original_Pid} != $$) or
- (!$self->{Have_Plan} && !$self->{Test_Died}) or
- $self->{Bailed_Out}
- )
- {
- _my_exit($?);
- return;
+ if( $self->{Bailed_Out} ) {
+ return;
}
# Figure out if we passed or failed and print helpful messages.
@@ -1652,7 +1773,7 @@ Looks like you failed $num_failed test$s
FAIL
}
- if( $self->{Test_Died} ) {
+ if( $real_exit_code ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
@@ -1676,7 +1797,7 @@ FAIL
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
- elsif ( $self->{Test_Died} ) {
+ elsif ( $real_exit_code ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
@@ -1713,10 +1834,13 @@ If you fail more than 254 tests, it will
=head1 THREADS
-In perl 5.8.0 and later, Test::Builder is thread-safe. The test
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test
number is shared amongst all threads. This means if one thread sets
the test number using current_test() they will all be effected.
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
+
Test::Builder is only thread-aware if threads.pm is loaded I<before>
Test::Builder.
diff -up perl-5.8.8/lib/Test/Simple.pm.crr perl-5.8.8/lib/Test/Simple.pm
--- perl-5.8.8/lib/Test/Simple.pm.crr 2005-10-08 08:56:17.000000000 +0200
+++ perl-5.8.8/lib/Test/Simple.pm 2008-02-27 11:01:46.000000000 +0100
@@ -4,7 +4,7 @@ use 5.004;
use strict 'vars';
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.62';
+$VERSION = '0.78';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/00test_harness_check.t /home/marca/Desktop/Test-Simple-0.78/t/00test_harness_check.t
--- perl-5.8.8/lib/Test/Simple/t/00test_harness_check.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/00test_harness_check.t 2006-10-14 03:46:51.000000000 +0200
@@ -8,7 +8,7 @@ plan tests => 1;
my $TH_Version = 2.03;
require Test::Harness;
-unless( cmp_ok( $Test::Harness::VERSION, '>', $TH_Version, "T::H version" ) ) {
+unless( cmp_ok( eval $Test::Harness::VERSION, '>=', $TH_Version, "T::H version" ) ) {
diag <<INSTRUCTIONS;
Test::Simple/More/Builder has features which depend on a version of
diff -uprNB perl-5.8.8/lib/Test/Simple/t/bail_out.t /home/marca/Desktop/Test-Simple-0.78/t/bail_out.t
--- perl-5.8.8/lib/Test/Simple/t/bail_out.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/bail_out.t 2006-09-04 10:23:12.000000000 +0200
@@ -28,7 +28,7 @@ my $Test = Test::Builder->create;
$Test->level(0);
if( $] >= 5.005 ) {
- $Test->plan(tests => 2);
+ $Test->plan(tests => 3);
}
else {
$Test->plan(skip_all =>
@@ -47,3 +47,5 @@ Bail out! ROCKS FALL! EVERYONE DIES!
OUT
$Test->is_eq( $Exit_Code, 255 );
+
+$Test->ok( $Test->can("BAILOUT"), "Backwards compat" );
diff -uprNB perl-5.8.8/lib/Test/Simple/t/BEGIN_require_ok.t /home/marca/Desktop/Test-Simple-0.78/t/BEGIN_require_ok.t
--- perl-5.8.8/lib/Test/Simple/t/BEGIN_require_ok.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/BEGIN_require_ok.t 2007-12-04 04:32:40.000000000 +0100
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::More;
+
+my $result;
+BEGIN {
+ eval {
+ require_ok("Wibble");
+ };
+ $result = $@;
+}
+
+plan tests => 1;
+like $result, '/^You tried to run a test without a plan/';
diff -uprNB perl-5.8.8/lib/Test/Simple/t/BEGIN_use_ok.t /home/marca/Desktop/Test-Simple-0.78/t/BEGIN_use_ok.t
--- perl-5.8.8/lib/Test/Simple/t/BEGIN_use_ok.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/BEGIN_use_ok.t 2007-09-20 05:16:02.000000000 +0200
@@ -0,0 +1,28 @@
+#!/usr/bin/perl -w
+
+# [rt.cpan.org 28345]
+#
+# A use_ok() inside a BEGIN block lacking a plan would be silently ignored.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::More;
+
+my $result;
+BEGIN {
+ eval {
+ use_ok("Wibble");
+ };
+ $result = $@;
+}
+
+plan tests => 1;
+like $result, '/^You tried to run a test without a plan/';
diff -uprNB perl-5.8.8/lib/Test/Simple/t/carp.t /home/marca/Desktop/Test-Simple-0.78/t/carp.t
--- perl-5.8.8/lib/Test/Simple/t/carp.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/carp.t 2006-10-24 22:40:43.000000000 +0200
@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+
+use Test::More tests => 3;
+use Test::Builder;
+
+my $tb = Test::Builder->create;
+sub foo { $tb->croak("foo") }
+sub bar { $tb->carp("bar") }
+
+eval { foo() };
+is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1;
+
+eval { $tb->croak("this") };
+is $@, sprintf "this at %s line %s.\n", $0, __LINE__ - 1;
+
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub {
+ $warning .= join '', @_;
+ };
+
+ bar();
+ is $warning, sprintf "bar at %s line %s.\n", $0, __LINE__ - 1;
+}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/cmp_ok.t /home/marca/Desktop/Test-Simple-0.78/t/cmp_ok.t
--- perl-5.8.8/lib/Test/Simple/t/cmp_ok.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/cmp_ok.t 2007-09-14 05:40:27.000000000 +0200
@@ -0,0 +1,82 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+local $ENV{HARNESS_ACTIVE} = 0;
+
+require Test::Builder;
+my $TB = Test::Builder->create;
+$TB->level(0);
+
+sub try_cmp_ok {
+ my($left, $cmp, $right) = @_;
+
+ my %expect;
+ $expect{ok} = eval "\$left $cmp \$right";
+ $expect{error} = $@;
+ $expect{error} =~ s/ at .*\n?//;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $ok = cmp_ok($left, $cmp, $right);
+ $TB->is_num(!!$ok, !!$expect{ok});
+
+ my $diag = $err->read;
+ if( !$ok and $expect{error} ) {
+ $diag =~ s/^# //mg;
+ $TB->like( $diag, "/\Q$expect{error}\E/" );
+ }
+ elsif( $ok ) {
+ $TB->is_eq( $diag, '' );
+ }
+ else {
+ $TB->ok(1);
+ }
+}
+
+
+use Test::More;
+Test::More->builder->no_ending(1);
+
+my @Tests = (
+ [1, '==', 1],
+ [1, '==', 2],
+ ["a", "eq", "b"],
+ ["a", "eq", "a"],
+ [1, "+", 1],
+ [1, "-", 1],
+);
+
+# These don't work yet.
+if( 0 ) {
+#if( eval { require overload } ) {
+ require MyOverload;
+
+ my $cmp = Overloaded::Compare->new("foo", 42);
+ my $ify = Overloaded::Ify->new("bar", 23);
+
+ push @Tests, (
+ [$cmp, '==', 42],
+ [$cmp, 'eq', "foo"],
+ [$ify, 'eq', "bar"],
+ [$ify, "==", 23],
+ );
+}
+
+plan tests => scalar @Tests;
+$TB->plan(tests => @Tests * 2);
+
+for my $test (@Tests) {
+ try_cmp_ok(@$test);
+}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/diag.t /home/marca/Desktop/Test-Simple-0.78/t/diag.t
--- perl-5.8.8/lib/Test/Simple/t/diag.t 2004-12-01 22:14:31.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/diag.t 2008-02-26 22:01:45.000000000 +0100
@@ -15,7 +15,7 @@ BEGIN {
# lots of threading bugs.
use Config;
BEGIN {
- if( $] >= 5.008 && $Config{useithreads} ) {
+ if( $] >= 5.008001 && $Config{useithreads} ) {
require threads;
'threads'->import;
}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/dont_overwrite_die_handler.t /home/marca/Desktop/Test-Simple-0.78/t/dont_overwrite_die_handler.t
--- perl-5.8.8/lib/Test/Simple/t/dont_overwrite_die_handler.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/dont_overwrite_die_handler.t 2008-02-24 04:33:47.000000000 +0100
@@ -0,0 +1,19 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+# Make sure this is in place before Test::More is loaded.
+my $handler_called;
+BEGIN {
+ $SIG{__DIE__} = sub { $handler_called++ };
+}
+
+use Test::More tests => 2;
+
+ok !eval { die };
+is $handler_called, 1, 'existing DIE handler not overridden';
diff -uprNB perl-5.8.8/lib/Test/Simple/t/exit.t /home/marca/Desktop/Test-Simple-0.78/t/exit.t
--- perl-5.8.8/lib/Test/Simple/t/exit.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/exit.t 2008-02-24 04:29:39.000000000 +0100
@@ -25,18 +25,9 @@ if( $^O eq 'MacOS' ) {
exit 0;
}
-my $test_num = 1;
-# Utility testing functions.
-sub ok ($;$) {
- my($test, $name) = @_;
- my $ok = '';
- $ok .= "not " unless $test;
- $ok .= "ok $test_num";
- $ok .= " - $name" if defined $name;
- $ok .= "\n";
- print $ok;
- $test_num++;
-}
+require Test::Builder;
+my $TB = Test::Builder->create();
+$TB->level(0);
package main;
@@ -59,10 +50,11 @@ my %Tests = (
'pre_plan_death.plx' => ['not zero', 'not zero'],
'death_in_eval.plx' => [0, 0],
'require.plx' => [0, 0],
- 'exit.plx' => [1, 4],
+# 'death_with_handler.plx' => [255, 4],
+ 'exit.plx' => [1, 4],
);
-print "1..".keys(%Tests)."\n";
+$TB->plan( tests => scalar keys(%Tests) );
eval { require POSIX; &POSIX::WEXITSTATUS(0) };
if( $@ ) {
@@ -93,12 +85,12 @@ while( my($test_name, $exit_codes) = eac
my $actual_exit = exitstatus($wait_stat);
if( $exit_code eq 'not zero' ) {
- My::Test::ok( $actual_exit != 0,
+ $TB->isnt_num( $actual_exit, 0,
"$test_name exited with $actual_exit ".
"(expected $exit_code)");
}
else {
- My::Test::ok( $actual_exit == $exit_code,
+ $TB->is_num( $actual_exit, $exit_code,
"$test_name exited with $actual_exit ".
"(expected $exit_code)");
}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/extra.t /home/marca/Desktop/Test-Simple-0.78/t/extra.t
--- perl-5.8.8/lib/Test/Simple/t/extra.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/extra.t 2006-09-04 10:23:12.000000000 +0200
@@ -48,9 +48,9 @@ OUT
$TB->is_eq($$err, <<ERR);
# Failed test 'Bar'
-# in $0 at line 31.
+# at $0 line 31.
# Failed test 'Sar'
-# in $0 at line 34.
+# at $0 line 34.
# Looks like you planned 3 tests but ran 2 extra.
# Looks like you failed 2 tests of 5 run.
ERR
diff -uprNB perl-5.8.8/lib/Test/Simple/t/fail-like.t /home/marca/Desktop/Test-Simple-0.78/t/fail-like.t
--- perl-5.8.8/lib/Test/Simple/t/fail-like.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/fail-like.t 2006-09-04 10:23:44.000000000 +0200
@@ -54,7 +54,7 @@ OUT
my $err_re = <<ERR;
# Failed test 'is foo like that'
-# in .* at line 1\.
+# at .* line 1\.
# 'foo'
# doesn't match '\\(\\?-xism:that\\)'
# Looks like you failed 1 test of 1\\.
diff -uprNB perl-5.8.8/lib/Test/Simple/t/fail-more.t /home/marca/Desktop/Test-Simple-0.78/t/fail-more.t
--- perl-5.8.8/lib/Test/Simple/t/fail-more.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/fail-more.t 2007-09-14 05:12:35.000000000 +0200
@@ -45,9 +45,13 @@ sub main::err_ok ($) {
package main;
require Test::More;
-my $Total = 28;
+my $Total = 30;
Test::More->import(tests => $Total);
+# This should all work in the presence of a __DIE__ handler.
+local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); };
+
+
my $tb = Test::More->builder;
$tb->use_numbers(0);
@@ -58,7 +62,7 @@ my $Filename = quotemeta $0;
ok( 0, 'failing' );
err_ok( <<ERR );
# Failed test 'failing'
-# in $0 at line 38.
+# at $0 line 38.
ERR
#line 40
@@ -68,19 +72,19 @@ is( undef, 0, 'undef is 0?');
is( '', 0, 'empty string is 0?' );
err_ok( <<ERR );
# Failed test 'foo is bar?'
-# in $0 at line 40.
+# at $0 line 40.
# got: 'foo'
# expected: 'bar'
# Failed test 'undef is empty string?'
-# in $0 at line 41.
+# at $0 line 41.
# got: undef
# expected: ''
# Failed test 'undef is 0?'
-# in $0 at line 42.
+# at $0 line 42.
# got: undef
# expected: '0'
# Failed test 'empty string is 0?'
-# in $0 at line 43.
+# at $0 line 43.
# got: ''
# expected: '0'
ERR
@@ -91,17 +95,17 @@ isn't("foo", "foo",'foo isn\'t foo?' );
isnt(undef, undef, 'undef isnt undef?');
err_ok( <<ERR );
# Failed test 'foo isnt foo?'
-# in $0 at line 45.
+# at $0 line 45.
# 'foo'
# ne
# 'foo'
# Failed test 'foo isn\'t foo?'
-# in $0 at line 46.
+# at $0 line 46.
# 'foo'
# ne
# 'foo'
# Failed test 'undef isnt undef?'
-# in $0 at line 47.
+# at $0 line 47.
# undef
# ne
# undef
@@ -112,11 +116,11 @@ like( "foo", '/that/', 'is foo like tha
unlike( "foo", '/foo/', 'is foo unlike foo' );
err_ok( <<ERR );
# Failed test 'is foo like that'
-# in $0 at line 48.
+# at $0 line 48.
# 'foo'
# doesn't match '/that/'
# Failed test 'is foo unlike foo'
-# in $0 at line 49.
+# at $0 line 49.
# 'foo'
# matches '/foo/'
ERR
@@ -126,7 +130,7 @@ ERR
like( "bug", '/(%)/', 'regex with % in it' );
err_ok( <<ERR );
# Failed test 'regex with % in it'
-# in $0 at line 60.
+# at $0 line 60.
# 'bug'
# doesn't match '/(%)/'
ERR
@@ -135,20 +139,28 @@ ERR
fail('fail()');
err_ok( <<ERR );
# Failed test 'fail()'
-# in $0 at line 67.
+# at $0 line 67.
ERR
#line 52
can_ok('Mooble::Hooble::Yooble', qw(this that));
can_ok('Mooble::Hooble::Yooble', ());
+can_ok(undef, undef);
+can_ok([], "foo");
err_ok( <<ERR );
# Failed test 'Mooble::Hooble::Yooble->can(...)'
-# in $0 at line 52.
+# at $0 line 52.
# Mooble::Hooble::Yooble->can('this') failed
# Mooble::Hooble::Yooble->can('that') failed
# Failed test 'Mooble::Hooble::Yooble->can(...)'
-# in $0 at line 53.
+# at $0 line 53.
# can_ok() called with no methods
+# Failed test '->can(...)'
+# at $0 line 54.
+# can_ok() called with empty class or reference
+# Failed test 'ARRAY->can('foo')'
+# at $0 line 55.
+# ARRAY->can('foo') failed
ERR
#line 55
@@ -158,16 +170,16 @@ isa_ok(undef, "Wibble", "Another Wibble"
isa_ok([], "HASH");
err_ok( <<ERR );
# Failed test 'The object isa Wibble'
-# in $0 at line 55.
+# at $0 line 55.
# The object isn't a 'Wibble' it's a 'Foo'
# Failed test 'My Wibble isa Wibble'
-# in $0 at line 56.
+# at $0 line 56.
# My Wibble isn't a reference
# Failed test 'Another Wibble isa Wibble'
-# in $0 at line 57.
+# at $0 line 57.
# Another Wibble isn't defined
# Failed test 'The object isa HASH'
-# in $0 at line 58.
+# at $0 line 58.
# The object isn't a 'HASH' it's a 'ARRAY'
ERR
@@ -178,20 +190,20 @@ cmp_ok( 42, '!=', 42 , ' !='
cmp_ok( 1, '&&', 0 , ' &&' );
err_ok( <<ERR );
# Failed test 'cmp_ok eq'
-# in $0 at line 68.
+# at $0 line 68.
# got: 'foo'
# expected: 'bar'
# Failed test ' =='
-# in $0 at line 69.
+# at $0 line 69.
# got: 42.1
# expected: 23
# Failed test ' !='
-# in $0 at line 70.
+# at $0 line 70.
# '42'
# !=
# '42'
# Failed test ' &&'
-# in $0 at line 71.
+# at $0 line 71.
# '1'
# &&
# '0'
@@ -202,7 +214,7 @@ ERR
cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
err_ok( <<ERR );
# Failed test ' eq with numbers'
-# in $0 at line 196.
+# at $0 line 196.
# got: '42'
# expected: 'foo'
ERR
@@ -216,7 +228,7 @@ ERR
cmp_ok( 42, '==', "foo", ' == with strings' );
err_ok( <<ERR );
# Failed test ' == with strings'
-# in $0 at line 211.
+# at $0 line 211.
# got: 42
# expected: foo
ERR
@@ -235,11 +247,11 @@ cmp_ok( $!, 'eq', '', ' eq w
cmp_ok( $!, '==', -1, ' eq with numerified errno' );
err_ok( <<ERR );
# Failed test ' eq with stringified errno'
-# in $0 at line 80.
+# at $0 line 80.
# got: '$Errno_String'
# expected: ''
# Failed test ' eq with numerified errno'
-# in $0 at line 81.
+# at $0 line 81.
# got: $Errno_Number
# expected: -1
ERR
@@ -249,10 +261,9 @@ use_ok('Hooble::mooble::yooble');
my $more_err_re = <<ERR;
# Failed test 'use Hooble::mooble::yooble;'
-# in $Filename at line 84\\.
+# at $Filename line 84\\.
# Tried to use 'Hooble::mooble::yooble'.
# Error: Can't locate Hooble.* in \\\@INC .*
-# BEGIN failed--compilation aborted at $Filename line 84.
ERR
My::Test::like($err->read, "/^$more_err_re/");
@@ -262,7 +273,7 @@ My::Test::like($err->read, "/^$more_err_
require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
$more_err_re = <<ERR;
# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;'
-# in $Filename at line 85\\.
+# at $Filename line 85\\.
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
# Error: Can't locate ALL.* in \\\@INC .*
ERR
@@ -288,6 +299,8 @@ not ok - regex with % in it
not ok - fail()
not ok - Mooble::Hooble::Yooble->can(...)
not ok - Mooble::Hooble::Yooble->can(...)
+not ok - ->can(...)
+not ok - ARRAY->can('foo')
not ok - The object isa Wibble
not ok - My Wibble isa Wibble
not ok - Another Wibble isa Wibble
diff -uprNB perl-5.8.8/lib/Test/Simple/t/fail_one.t /home/marca/Desktop/Test-Simple-0.78/t/fail_one.t
--- perl-5.8.8/lib/Test/Simple/t/fail_one.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/fail_one.t 2006-09-04 10:23:12.000000000 +0200
@@ -53,7 +53,7 @@ not ok 1
OUT
My::Test::ok($$err eq <<ERR) || print $$err;
-# Failed test in $0 at line 45.
+# Failed test at $0 line 45.
# Looks like you failed 1 test of 1.
ERR
diff -uprNB perl-5.8.8/lib/Test/Simple/t/fail.t /home/marca/Desktop/Test-Simple-0.78/t/fail.t
--- perl-5.8.8/lib/Test/Simple/t/fail.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/fail.t 2006-09-04 10:23:12.000000000 +0200
@@ -61,9 +61,9 @@ OUT
My::Test::ok($$err eq <<ERR);
# Failed test 'oh no!'
-# in $0 at line 38.
+# at $0 line 38.
# Failed test 'damnit'
-# in $0 at line 39.
+# at $0 line 39.
# Looks like you failed 2 tests of 5.
ERR
diff -uprNB perl-5.8.8/lib/Test/Simple/t/filehandles.t /home/marca/Desktop/Test-Simple-0.78/t/filehandles.t
--- perl-5.8.8/lib/Test/Simple/t/filehandles.t 2002-01-11 15:23:49.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/filehandles.t 2008-02-24 04:44:49.000000000 +0100
@@ -3,19 +3,17 @@
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
- @INC = '../lib';
+ @INC = '../lib', 'lib';
}
}
+use lib 't/lib';
use Test::More tests => 1;
+use lib 'lib';
+use Dev::Null;
tie *STDOUT, "Dev::Null" or die $!;
print "not ok 1\n"; # this should not print.
pass 'STDOUT can be mucked with';
-
-package Dev::Null;
-
-sub TIEHANDLE { bless {} }
-sub PRINT { 1 }
diff -uprNB perl-5.8.8/lib/Test/Simple/t/harness_active.t /home/marca/Desktop/Test-Simple-0.78/t/harness_active.t
--- perl-5.8.8/lib/Test/Simple/t/harness_active.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/harness_active.t 2006-09-04 10:23:12.000000000 +0200
@@ -52,13 +52,13 @@ Test::More->builder->no_ending(1);
fail( "this fails" );
err_ok( <<ERR );
# Failed test 'this fails'
-# in $0 at line 62.
+# at $0 line 62.
ERR
#line 72
is( 1, 0 );
err_ok( <<ERR );
-# Failed test in $0 at line 72.
+# Failed test at $0 line 72.
# got: '1'
# expected: '0'
ERR
@@ -72,7 +72,7 @@ ERR
err_ok( <<ERR );
# Failed test 'this fails'
-# in $0 at line 71.
+# at $0 line 71.
ERR
@@ -80,7 +80,7 @@ ERR
is( 1, 0 );
err_ok( <<ERR );
-# Failed test in $0 at line 84.
+# Failed test at $0 line 84.
# got: '1'
# expected: '0'
ERR
diff -uprNB perl-5.8.8/lib/Test/Simple/t/is_deeply_dne_bug.t /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_dne_bug.t
--- perl-5.8.8/lib/Test/Simple/t/is_deeply_dne_bug.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_dne_bug.t 2007-09-14 04:50:17.000000000 +0200
@@ -0,0 +1,56 @@
+#!/usr/bin/perl -w
+
+# test for rt.cpan.org 20768
+#
+# There was a bug where the internal "does not exist" object could get
+# confused with an overloaded object.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More;
+
+BEGIN {
+ if( !eval "require overload" ) {
+ plan skip_all => "needs overload.pm";
+ }
+ else {
+ plan tests => 2;
+ }
+}
+
+{
+ package Foo;
+
+ use overload
+ 'eq' => \&overload_equiv,
+ '==' => \&overload_equiv;
+
+ sub new {
+ return bless {}, shift;
+ }
+
+ sub overload_equiv {
+ if (ref($_[0]) ne 'Foo' || ref($_[1]) ne 'Foo') {
+ print ref($_[0]), " ", ref($_[1]), "\n";
+ die "Invalid object passed to overload_equiv\n";
+ }
+
+ return 1; # change to 0 ... makes little difference
+ }
+}
+
+my $obj1 = Foo->new();
+my $obj2 = Foo->new();
+
+eval { is_deeply([$obj1, $obj2], [$obj1, $obj2]); };
+is $@, '';
+
diff -uprNB perl-5.8.8/lib/Test/Simple/t/is_deeply_fail.t /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_fail.t
--- perl-5.8.8/lib/Test/Simple/t/is_deeply_fail.t 2005-10-02 03:40:52.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_fail.t 2006-09-04 10:23:12.000000000 +0200
@@ -64,7 +64,7 @@ ok !is_deeply('foo', 'bar', 'plain strin
is( $out, "not ok 1 - plain strings\n", 'plain strings' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'plain strings'
-# in $0 at line 68.
+# at $0 line 68.
# got: 'foo'
# expected: 'bar'
ERR
@@ -75,7 +75,7 @@ ok !is_deeply({}, [], 'different types')
is( $out, "not ok 2 - different types\n", 'different types' );
like( $err, <<ERR, ' right diagnostic' );
# Failed test 'different types'
-# in $Filename at line 78.
+# at $Filename line 78.
# Structures begin differing at:
# \\\$got = HASH\\(0x[0-9a-f]+\\)
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
@@ -87,7 +87,7 @@ is( $out, "not ok 3 - hashes with differ
'hashes with different values' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes with different values'
-# in $0 at line 88.
+# at $0 line 88.
# Structures begin differing at:
# \$got->{this} = '42'
# \$expected->{this} = '43'
@@ -99,7 +99,7 @@ is( $out, "not ok 4 - hashes with differ
'hashes with different keys' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes with different keys'
-# in $0 at line 99.
+# at $0 line 99.
# Structures begin differing at:
# \$got->{this} = Does not exist
# \$expected->{this} = '42'
@@ -111,7 +111,7 @@ is( $out, "not ok 5 - arrays of differen
'arrays of different length' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'arrays of different length'
-# in $0 at line 110.
+# at $0 line 110.
# Structures begin differing at:
# \$got->[9] = Does not exist
# \$expected->[9] = '10'
@@ -122,7 +122,7 @@ ok !is_deeply([undef, undef], [undef], '
is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'arrays of undefs'
-# in $0 at line 121.
+# at $0 line 121.
# Structures begin differing at:
# \$got->[1] = undef
# \$expected->[1] = Does not exist
@@ -133,7 +133,7 @@ ok !is_deeply({ foo => undef }, {}, '
is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes of undefs'
-# in $0 at line 131.
+# at $0 line 131.
# Structures begin differing at:
# \$got->{foo} = undef
# \$expected->{foo} = Does not exist
@@ -144,7 +144,7 @@ ok !is_deeply(\42, \23, 'scalar refs')
is( $out, "not ok 8 - scalar refs\n", 'scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'scalar refs'
-# in $0 at line 141.
+# at $0 line 141.
# Structures begin differing at:
# \${ \$got} = '42'
# \${\$expected} = '23'
@@ -156,7 +156,7 @@ is( $out, "not ok 9 - mixed scalar and a
'mixed scalar and array refs' );
like( $err, <<ERR, ' right diagnostic' );
# Failed test 'mixed scalar and array refs'
-# in $Filename at line 151.
+# at $Filename line 151.
# Structures begin differing at:
# \\\$got = ARRAY\\(0x[0-9a-f]+\\)
# \\\$expected = SCALAR\\(0x[0-9a-f]+\\)
@@ -176,7 +176,7 @@ ok !is_deeply($a1, $b1, 'deep scalar ref
is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'deep scalar refs'
-# in $0 at line 173.
+# at $0 line 173.
# Structures begin differing at:
# \${\${ \$got}} = '42'
# \${\${\$expected}} = '23'
@@ -203,7 +203,7 @@ ok( @Test::More::Data_Stack == 0, '@Data
is( $out, "not ok 11 - deep structures\n", 'deep structures' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'deep structures'
-# in $0 at line 198.
+# at $0 line 198.
# Structures begin differing at:
# \$got->{that}{foo} = Does not exist
# \$expected->{that}{foo} = '42'
@@ -252,7 +252,7 @@ $$err = $$out = '';
ok !is_deeply( [\'a', 'b'], [\'a', 'c'] );
is( $out, "not ok 20\n", 'scalar refs in an array' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test in $0 at line 274.
+# Failed test at $0 line 274.
# Structures begin differing at:
# \$got->[1] = 'b'
# \$expected->[1] = 'c'
@@ -264,7 +264,7 @@ my $ref = \23;
ok !is_deeply( 23, $ref );
is( $out, "not ok 21\n", 'scalar vs ref' );
is( $err, <<ERR, ' right diagnostic');
-# Failed test in $0 at line 286.
+# Failed test at $0 line 286.
# Structures begin differing at:
# \$got = '23'
# \$expected = $ref
@@ -274,7 +274,7 @@ ERR
ok !is_deeply( $ref, 23 );
is( $out, "not ok 22\n", 'ref vs scalar' );
is( $err, <<ERR, ' right diagnostic');
-# Failed test in $0 at line 296.
+# Failed test at $0 line 296.
# Structures begin differing at:
# \$got = $ref
# \$expected = '23'
@@ -284,7 +284,7 @@ ERR
ok !is_deeply( undef, [] );
is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test in $Filename at line 306\\.
+# Failed test at $Filename line 306\\.
# Structures begin differing at:
# \\\$got = undef
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
@@ -300,7 +300,7 @@ ERR
ok !is_deeply( $array, $hash );
is( $out, "not ok 24\n", 'is_deeply and different reference types' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test in $0 at line 321.
+# Failed test at $0 line 321.
# Structures begin differing at:
# \$got = $array
# \$expected = $hash
@@ -310,7 +310,7 @@ ERR
ok !is_deeply( [$array], [$hash] );
is( $out, "not ok 25\n", 'nested different ref types' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test in $0 at line 332.
+# Failed test at $0 line 332.
# Structures begin differing at:
# \$got->[0] = $array
# \$expected->[0] = $hash
@@ -330,7 +330,7 @@ ERR
ok !is_deeply( [$foo], [$bar] );
is( $out, "not ok 26\n", 'string overloaded refs respected in diag' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test in $0 at line 353.
+# Failed test at $0 line 353.
# Structures begin differing at:
# \$got->[0] = $foo
# \$expected->[0] = 'wibble'
@@ -349,7 +349,7 @@ ERR
ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs';
is( $out, "not ok 27\n" );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test in $Filename at line 349.
+# Failed test at $Filename line 349.
# Structures begin differing at:
# \\\$got = CODE\\(0x[0-9a-f]+\\)
# \\\$expected = CODE\\(0x[0-9a-f]+\\)
@@ -364,7 +364,7 @@ ERR
ok !is_deeply( $glob1, $glob2 ), 'typeglobs';
is( $out, "not ok 28\n" );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test in $0 at line 357.
+# Failed test at $Filename line 357.
# Structures begin differing at:
# \\\$got = GLOB\\(0x[0-9a-f]+\\)
# \\\$expected = GLOB\\(0x[0-9a-f]+\\)
diff -uprNB perl-5.8.8/lib/Test/Simple/t/is_deeply_with_threads.t /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_with_threads.t
--- perl-5.8.8/lib/Test/Simple/t/is_deeply_with_threads.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/is_deeply_with_threads.t 2008-02-24 04:12:32.000000000 +0100
@@ -0,0 +1,65 @@
+#!/usr/bin/perl -w
+
+# Test to see if is_deeply() plays well with threads.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Config;
+
+BEGIN {
+ unless ( $] >= 5.008001 && $Config{'useithreads'} &&
+ eval { require threads; 'threads'->import; 1; })
+ {
+ print "1..0 # Skip: no working threads\n";
+ exit 0;
+ }
+
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip: many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+use Test::More;
+
+my $Num_Threads = 5;
+
+plan tests => $Num_Threads * 100 + 6;
+
+
+sub do_one_thread {
+ my $kid = shift;
+ my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
+ 'hello', 's', 'thisisalongname', '1', '2', '3',
+ 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
+ my @list2 = @list;
+ print "# kid $kid before is_deeply\n";
+
+ for my $j (1..100) {
+ is_deeply(\@list, \@list2);
+ }
+ print "# kid $kid exit\n";
+ return 42;
+}
+
+my @kids = ();
+for my $i (1..$Num_Threads) {
+ my $t = threads->new(\&do_one_thread, $i);
+ print "# parent $$: continue\n";
+ push(@kids, $t);
+}
+for my $t (@kids) {
+ print "# parent $$: waiting for join\n";
+ my $rc = $t->join();
+ cmp_ok( $rc, '==', 42, "threads exit status is $rc" );
+}
+
+pass("End of test");
diff -uprNB perl-5.8.8/lib/Test/Simple/t/is_fh.t /home/marca/Desktop/Test-Simple-0.78/t/is_fh.t
--- perl-5.8.8/lib/Test/Simple/t/is_fh.t 2005-05-05 17:06:46.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/is_fh.t 2007-09-14 04:34:50.000000000 +0200
@@ -11,19 +11,38 @@ BEGIN {
}
use strict;
-use Test::More tests => 8;
+use Test::More tests => 11;
use TieOut;
-ok( !Test::Builder::_is_fh("foo"), 'string is not a filehandle' );
-ok( !Test::Builder::_is_fh(''), 'empty string' );
-ok( !Test::Builder::_is_fh(undef), 'undef' );
+ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' );
+ok( !Test::Builder->is_fh(''), 'empty string' );
+ok( !Test::Builder->is_fh(undef), 'undef' );
ok( open(FILE, '>foo') );
-END { close FILE; unlink 'foo' }
+END { close FILE; 1 while unlink 'foo' }
-ok( Test::Builder::_is_fh(*FILE) );
-ok( Test::Builder::_is_fh(\*FILE) );
-ok( Test::Builder::_is_fh(*FILE{IO}) );
+ok( Test::Builder->is_fh(*FILE) );
+ok( Test::Builder->is_fh(\*FILE) );
+ok( Test::Builder->is_fh(*FILE{IO}) );
tie *OUT, 'TieOut';
-ok( Test::Builder::_is_fh(*OUT) );
+ok( Test::Builder->is_fh(*OUT) );
+ok( Test::Builder->is_fh(\*OUT) );
+
+SKIP: {
+ skip "*TIED_HANDLE{IO} doesn't work in this perl", 1
+ unless defined *OUT{IO};
+ ok( Test::Builder->is_fh(*OUT{IO}) );
+}
+
+
+package Lying::isa;
+
+sub isa {
+ my $self = shift;
+ my $parent = shift;
+
+ return 1 if $parent eq 'IO::Handle';
+}
+
+::ok( Test::Builder->is_fh(bless {}, "Lying::isa"));
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Dev/Null.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/Dev/Null.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/Dev/Null.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Dev/Null.pm 2008-02-24 04:44:15.000000000 +0100
@@ -0,0 +1,6 @@
+package Dev::Null;
+
+sub TIEHANDLE { bless {} }
+sub PRINT { 1 }
+
+1;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Dummy.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/Dummy.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/Dummy.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Dummy.pm 2008-02-24 04:03:26.000000000 +0100
@@ -0,0 +1,5 @@
+package Dummy;
+
+$VERSION = '0.01';
+
+1;
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/MyOverload.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/MyOverload.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/MyOverload.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/MyOverload.pm 2008-02-24 04:03:15.000000000 +0100
@@ -0,0 +1,29 @@
+package Overloaded;
+
+sub new {
+ my $class = shift;
+ bless { string => shift, num => shift }, $class;
+}
+
+
+package Overloaded::Compare;
+use vars qw(@ISA);
+@ISA = qw(Overloaded);
+
+# Sometimes objects have only comparison ops overloaded and nothing else.
+# For example, DateTime objects.
+use overload
+ q{eq} => sub { $_[0]->{string} eq $_[1] },
+ q{==} => sub { $_[0]->{num} == $_[1] };
+
+
+
+package Overloaded::Ify;
+use vars qw(@ISA);
+@ISA = qw(Overloaded);
+
+use overload
+ q{""} => sub { $_[0]->{string} },
+ q{0+} => sub { $_[0]->{num} };
+
+1;
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/NoExporter.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/NoExporter.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/NoExporter.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/NoExporter.pm 2008-02-24 04:03:27.000000000 +0100
@@ -0,0 +1,10 @@
+package NoExporter;
+
+$VERSION = 1.02;
+sub import {
+ shift;
+ die "NoExporter exports nothing. You asked for: @_" if @_;
+}
+
+1;
+
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/Catch.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/Catch.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/Catch.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/Catch.pm 2008-02-24 04:03:15.000000000 +0100
@@ -0,0 +1,18 @@
+# For testing Test::Simple;
+package Test::Simple::Catch;
+
+use Symbol;
+use TieOut;
+my($out_fh, $err_fh) = (gensym, gensym);
+my $out = tie *$out_fh, 'TieOut';
+my $err = tie *$err_fh, 'TieOut';
+
+use Test::Builder;
+my $t = Test::Builder->new;
+$t->output($out_fh);
+$t->failure_output($err_fh);
+$t->todo_output($err_fh);
+
+sub caught { return($out, $err) }
+
+1;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death_in_eval.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death_in_eval.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,22 @@
+require Test::Simple;
+use Carp;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(1);
+ok(1);
+ok(1);
+eval {
+ die "Foo";
+};
+ok(1);
+eval "die 'Bar'";
+ok(1);
+
+eval {
+ croak "Moo";
+};
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death.plx 2008-02-24 05:39:20.000000000 +0100
@@ -0,0 +1,15 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+require Dev::Null;
+
+Test::Simple->import(tests => 5);
+tie *STDERR, 'Dev::Null';
+
+ok(1);
+ok(1);
+ok(1);
+die "This is a test";
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death_with_handler.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/death_with_handler.plx 2008-02-24 05:38:55.000000000 +0100
@@ -0,0 +1,18 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 2);
+
+# Test we still get the right exit code despite having a die
+# handler.
+$SIG{__DIE__} = sub {};
+
+require Dev::Null;
+tie *STDERR, 'Dev::Null';
+
+ok(1);
+ok(1);
+die "This is a test";
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/exit.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/exit.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/exit.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/exit.plx 2006-08-31 07:24:17.000000000 +0200
@@ -0,0 +1,3 @@
+require Test::Builder;
+
+exit 1;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/extras.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/extras.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/extras.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/extras.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,16 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+ok(0);
+ok(1);
+ok(0);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/five_fail.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/five_fail.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/five_fail.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/five_fail.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,13 @@
+require Test::Simple;
+
+use lib 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(0);
+ok(0);
+ok('');
+ok(0);
+ok(0);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/last_minute_death.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2008-02-24 05:39:07.000000000 +0100
@@ -0,0 +1,18 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+require Dev::Null;
+tie *STDERR, 'Dev::Null';
+
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+ok(1);
+
+die "This is a test";
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/one_fail.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/one_fail.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/one_fail.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/one_fail.plx 2006-08-31 07:24:17.000000000 +0200
@@ -0,0 +1,14 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(2);
+ok(0);
+ok(1);
+ok(2);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/pre_plan_death.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/pre_plan_death.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,17 @@
+# ID 20020716.013, the exit code would become 0 if the test died
+# before a plan.
+
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+close STDERR;
+die "Knife?";
+
+Test::Simple->import(tests => 3);
+
+ok(1);
+ok(1);
+ok(1);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/require.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/require.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/require.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/require.plx 2006-08-31 07:24:17.000000000 +0200
@@ -0,0 +1 @@
+require Test::Simple;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/success.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/success.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/success.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/success.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,13 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+ok(1);
+ok(5, 'yep');
+ok(3, 'beer');
+ok("wibble", "wibble");
+ok(1);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/too_few_fail.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/too_few_fail.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,12 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(0);
+ok(1);
+ok(0);
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/too_few.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/too_few.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/too_few.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/too_few.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,11 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(1);
+ok(1);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/two_fail.plx /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/two_fail.plx
--- perl-5.8.8/lib/Test/Simple/t/lib/Test/Simple/sample_tests/two_fail.plx 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/Test/Simple/sample_tests/two_fail.plx 2006-08-31 07:24:16.000000000 +0200
@@ -0,0 +1,14 @@
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(0);
+ok(1);
+ok(1);
+ok(0);
+ok(1);
diff -uprNB perl-5.8.8/lib/Test/Simple/t/lib/TieOut.pm /home/marca/Desktop/Test-Simple-0.78/t/lib/TieOut.pm
--- perl-5.8.8/lib/Test/Simple/t/lib/TieOut.pm 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/lib/TieOut.pm 2008-02-24 04:03:15.000000000 +0100
@@ -0,0 +1,28 @@
+package TieOut;
+
+sub TIEHANDLE {
+ my $scalar = '';
+ bless( \$scalar, $_[0]);
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub PRINTF {
+ my $self = shift;
+ my $fmt = shift;
+ $$self .= sprintf $fmt, @_;
+}
+
+sub FILENO {}
+
+sub read {
+ my $self = shift;
+ my $data = $$self;
+ $$self = '';
+ return $data;
+}
+
+1;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/maybe_regex.t /home/marca/Desktop/Test-Simple-0.78/t/maybe_regex.t
--- perl-5.8.8/lib/Test/Simple/t/maybe_regex.t 2004-12-29 13:16:16.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/maybe_regex.t 2008-02-24 05:08:29.000000000 +0100
@@ -11,22 +11,24 @@ BEGIN {
}
use strict;
-use Test::More tests => 13;
+use Test::More tests => 16;
use Test::Builder;
my $Test = Test::Builder->new;
-SKIP: {
- skip "qr// added in 5.005", 3 if $] < 5.005;
+my $r = $Test->maybe_regex(qr/^FOO$/i);
+ok(defined $r, 'qr// detected');
+ok(('foo' =~ /$r/), 'qr// good match');
+ok(('bar' !~ /$r/), 'qr// bad match');
- # 5.004 can't even see qr// or it pukes in compile.
- eval q{
- my $r = $Test->maybe_regex(qr/^FOO$/i);
- ok(defined $r, 'qr// detected');
- ok(('foo' =~ /$r/), 'qr// good match');
- ok(('bar' !~ /$r/), 'qr// bad match');
- };
- die $@ if $@;
+SKIP: {
+ skip "blessed regex checker added in 5.10", 3 if $] < 5.010;
+
+ my $obj = bless qr/foo/, 'Wibble';
+ my $re = $Test->maybe_regex($obj);
+ ok( defined $re, "blessed regex detected" );
+ ok( ('foo' =~ /$re/), 'blessed qr/foo/ good match' );
+ ok( ('bar' !~ /$re/), 'blessed qr/foo/ bad math' );
}
{
diff -uprNB perl-5.8.8/lib/Test/Simple/t/missing.t /home/marca/Desktop/Test-Simple-0.78/t/missing.t
--- perl-5.8.8/lib/Test/Simple/t/missing.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/missing.t 2006-09-04 10:23:12.000000000 +0200
@@ -43,7 +43,7 @@ OUT
My::Test::is($$err, <<ERR);
# Failed test 'Bar'
-# in $0 at line 31.
+# at $0 line 31.
# Looks like you planned 5 tests but only ran 2.
# Looks like you failed 1 test of 2 run.
ERR
diff -uprNB perl-5.8.8/lib/Test/Simple/t/More.t /home/marca/Desktop/Test-Simple-0.78/t/More.t
--- perl-5.8.8/lib/Test/Simple/t/More.t 2005-10-02 03:40:51.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/More.t 2007-08-16 00:24:14.000000000 +0200
@@ -7,7 +7,7 @@ BEGIN {
}
}
-use Test::More tests => 51;
+use Test::More tests => 50;
# Make sure we don't mess with $@ or $!. Test at bottom.
my $Err = "this should not be touched";
@@ -15,7 +16,8 @@ my $Errno = 42;
$@ = $Err;
$! = $Errno;
-use_ok('Text::Soundex');
+#use_ok('Dummy');
+#is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' );
require_ok('Test::More');
diff -uprNB perl-5.8.8/lib/Test/Simple/t/no_plan.t /home/marca/Desktop/Test-Simple-0.78/t/no_plan.t
--- perl-5.8.8/lib/Test/Simple/t/no_plan.t 2002-01-11 15:23:49.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/no_plan.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,3 +1,5 @@
+#!/usr/bin/perl -w
+
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@@ -8,66 +10,19 @@ BEGIN {
}
}
-# Can't use Test.pm, that's a 5.005 thing.
-package My::Test;
-
-print "1..12\n";
-
-my $test_num = 1;
-# Utility testing functions.
-sub ok ($;$) {
- my($test, $name) = @_;
- my $ok = '';
- $ok .= "not " unless $test;
- $ok .= "ok $test_num";
- $ok .= " - $name" if defined $name;
- $ok .= "\n";
- print $ok;
- $test_num++;
-}
-
-
-package main;
-
-require Test::Simple;
-
-require Test::Simple::Catch;
-my($out, $err) = Test::Simple::Catch::caught();
-
-eval {
- Test::Simple->import;
-};
+use Test::More tests => 6;
-My::Test::ok($$out eq '');
-My::Test::ok($$err eq '');
-My::Test::ok($@ eq '');
+my $tb = Test::Builder->create;
+$tb->level(0);
-eval {
- Test::Simple->import(tests => undef);
-};
-
-My::Test::ok($$out eq '');
-My::Test::ok($$err eq '');
-My::Test::ok($@ =~ /Got an undefined number of tests/);
-
-eval {
- Test::Simple->import(tests => 0);
-};
-
-My::Test::ok($$out eq '');
-My::Test::ok($$err eq '');
-My::Test::ok($@ =~ /You said to run 0 tests!/);
-
-eval {
- Test::Simple::ok(1);
-};
-My::Test::ok( $@ =~ /You tried to run a test without a plan!/);
-
-
-END {
- My::Test::ok($$out eq '');
- My::Test::ok($$err eq "");
-
- # Prevent Test::Simple from exiting with non zero.
- exit 0;
-}
+#line 19
+ok !eval { $tb->plan(tests => undef) };
+is($@, "Got an undefined number of tests at $0 line 19.\n");
+
+#line 23
+ok !eval { $tb->plan(tests => 0) };
+is($@, "You said to run 0 tests at $0 line 23.\n");
+
+#line 27
+ok !eval { $tb->ok(1) };
+is( $@, "You tried to run a test without a plan at $0 line 27.\n");
diff -uprNB perl-5.8.8/lib/Test/Simple/t/output.t /home/marca/Desktop/Test-Simple-0.78/t/output.t
--- perl-5.8.8/lib/Test/Simple/t/output.t 2004-12-01 21:26:53.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/output.t 2007-09-14 04:34:24.000000000 +0200
@@ -37,7 +37,7 @@ my $Test = Test::Builder->new();
my $result;
my $tmpfile = 'foo.tmp';
my $out = $Test->output($tmpfile);
-END { unlink($tmpfile) }
+END { 1 while unlink($tmpfile) }
ok( defined $out );
diff -uprNB perl-5.8.8/lib/Test/Simple/t/overload.t /home/marca/Desktop/Test-Simple-0.78/t/overload.t
--- perl-5.8.8/lib/Test/Simple/t/overload.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/overload.t 2007-03-14 01:14:20.000000000 +0100
@@ -37,6 +37,12 @@ sub new {
package main;
+local $SIG{__DIE__} = sub {
+ my($call_file, $call_line) = (caller)[1,2];
+ fail("SIGDIE accidentally called");
+ diag("From $call_file at $call_line");
+};
+
my $obj = Overloaded->new('foo', 42);
isa_ok $obj, 'Overloaded';
diff -uprNB perl-5.8.8/lib/Test/Simple/t/plan_bad.t /home/marca/Desktop/Test-Simple-0.78/t/plan_bad.t
--- perl-5.8.8/lib/Test/Simple/t/plan_bad.t 2004-11-29 13:55:52.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/plan_bad.t 2006-09-04 10:23:12.000000000 +0200
@@ -8,57 +8,27 @@ BEGIN {
}
-# Can't use Test.pm, that's a 5.005 thing.
-package My::Test;
+use Test::More tests => 10;
+use Test::Builder;
+my $tb = Test::Builder->create;
+$tb->level(0);
-print "1..7\n";
-
-my $test_num = 1;
-# Utility testing functions.
-sub ok ($;$) {
- my($test, $name) = @_;
- my $ok = '';
- $ok .= "not " unless $test;
- $ok .= "ok $test_num";
- $ok .= " - $name" if defined $name;
- $ok .= "\n";
- print $ok;
- $test_num++;
-
- return $test;
-}
-
-
-sub is ($$;$) {
- my($this, $that, $name) = @_;
- my $test = $this eq $that;
- my $ok = '';
- $ok .= "not " unless $test;
- $ok .= "ok $test_num";
- $ok .= " - $name" if defined $name;
- $ok .= "\n";
- print $ok;
-
- unless( $test ) {
- print "# got \n$this";
- print "# expected \n$that";
- }
- $test_num++;
-
- return $test;
-}
-
-
-use Test::More import => ['plan'];
-
-ok !eval { plan tests => 'no_plan'; };
-is $@, "Number of tests must be a postive integer. You gave it 'no_plan'.\n";
+ok !eval { $tb->plan( tests => 'no_plan' ); };
+is $@, sprintf "Number of tests must be a positive integer. You gave it 'no_plan' at %s line %d.\n", $0, __LINE__ - 1;
my $foo = [];
my @foo = ($foo, 2, 3);
-ok !eval { plan tests => @foo };
-is $@, "Number of tests must be a postive integer. You gave it '$foo'.\n";
+ok !eval { $tb->plan( tests => @foo ) };
+is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1;
-ok !eval { plan tests => 0 };
-ok !eval { plan tests => -1 };
-ok !eval { plan tests => '' };
+#line 25
+ok !eval { $tb->plan( tests => -1 ) };
+is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n";
+
+#line 29
+ok !eval { $tb->plan( tests => '' ) };
+is $@, "You said to run 0 tests at $0 line 29.\n";
+
+#line 33
+ok !eval { $tb->plan( 'wibble' ) };
+is $@, "plan() doesn't understand wibble at $0 line 33.\n";
diff -uprNB perl-5.8.8/lib/Test/Simple/t/plan.t /home/marca/Desktop/Test-Simple-0.78/t/plan.t
--- perl-5.8.8/lib/Test/Simple/t/plan.t 2002-08-26 16:14:12.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/plan.t 2006-09-04 10:23:12.000000000 +0200
@@ -11,9 +11,11 @@ use Test::More;
plan tests => 4;
eval { plan tests => 4 };
-like( $@, '/^You tried to plan twice!/', 'disallow double plan' );
+is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ - 1),
+ 'disallow double plan' );
eval { plan 'no_plan' };
-like( $@, '/^You tried to plan twice!/', 'disallow chaning plan' );
+is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ -1),
+ 'disallow changing plan' );
pass('Just testing plan()');
pass('Testing it some more');
diff -uprNB perl-5.8.8/lib/Test/Simple/t/pod-coverage.t /home/marca/Desktop/Test-Simple-0.78/t/pod-coverage.t
--- perl-5.8.8/lib/Test/Simple/t/pod-coverage.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/pod-coverage.t 2007-03-14 01:21:10.000000000 +0100
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use Test::More;
+
+# 1.08 added the coverage_class option.
+eval "use Test::Pod::Coverage 1.08";
+plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@;
+eval "use Pod::Coverage::CountParents";
+plan skip_all => "Pod::Coverage::CountParents required for testing POD coverage" if $@;
+
+my @modules = Test::Pod::Coverage::all_modules();
+plan tests => scalar @modules;
+
+my %coverage_params = (
+ "Test::Builder" => {
+ also_private => [ '^(share|lock|BAILOUT)$' ]
+ },
+ "Test::More" => {
+ trustme => [ '^(skip|todo)$' ]
+ },
+);
+
+for my $module (@modules) {
+ pod_coverage_ok( $module, { coverage_class => 'Pod::Coverage::CountParents',
+ %{$coverage_params{$module} || {}} }
+ );
+}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/pod.t /home/marca/Desktop/Test-Simple-0.78/t/pod.t
--- perl-5.8.8/lib/Test/Simple/t/pod.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/pod.t 2006-10-24 23:08:10.000000000 +0200
@@ -0,0 +1,6 @@
+#!/usr/bin/perl -w
+
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
diff -uprNB perl-5.8.8/lib/Test/Simple/t/reset.t /home/marca/Desktop/Test-Simple-0.78/t/reset.t
--- perl-5.8.8/lib/Test/Simple/t/reset.t 2005-02-05 14:09:20.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/reset.t 2008-02-24 05:31:07.000000000 +0100
@@ -16,6 +16,11 @@ chdir 't';
use Test::Builder;
my $tb = Test::Builder->new;
+
+my %Original_Output;
+$Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output);
+
+
$tb->plan(tests => 14);
$tb->level(0);
@@ -66,11 +71,11 @@ ok( $tb->level == 1,
ok( $tb->use_numbers == 1, 'use_numbers' );
ok( $tb->no_header == 0, 'no_header' );
ok( $tb->no_ending == 0, 'no_ending' );
-ok( fileno $tb->output == fileno *Test::Builder::TESTOUT,
+ok( fileno $tb->output == fileno $Original_Output{output},
'output' );
-ok( fileno $tb->failure_output == fileno *Test::Builder::TESTERR,
+ok( fileno $tb->failure_output == fileno $Original_Output{failure_output},
'failure_output' );
-ok( fileno $tb->todo_output == fileno *Test::Builder::TESTOUT,
+ok( fileno $tb->todo_output == fileno $Original_Output{todo_output},
'todo_output' );
ok( $tb->current_test == 0, 'current_test' );
ok( $tb->summary == 0, 'summary' );
diff -uprNB perl-5.8.8/lib/Test/Simple/t/skip.t /home/marca/Desktop/Test-Simple-0.78/t/skip.t
--- perl-5.8.8/lib/Test/Simple/t/skip.t 2002-01-11 15:23:49.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/skip.t 2006-09-04 10:23:12.000000000 +0200
@@ -7,7 +7,7 @@ BEGIN {
}
}
-use Test::More tests => 15;
+use Test::More tests => 17;
# If we skip with the same name, Test::Harness will report it back and
# we won't get lots of false bug reports.
@@ -84,3 +84,15 @@ SKIP: {
pass("This is supposed to run, too");
}
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning .= join "", @_ };
+
+ SKIP: {
+ skip 1, "This is backwards" if 1;
+
+ pass "This does not run";
+ }
+
+ like $warning, '/^skip\(\) was passed a non-numeric number of tests/';
+}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t /home/marca/Desktop/Test-Simple-0.78/t/tbm_doesnt_set_exported_to.t
--- perl-5.8.8/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbm_doesnt_set_exported_to.t 2008-02-26 21:45:20.000000000 +0100
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use warnings;
+
+# Can't use Test::More, that would set exported_to()
+use Test::Builder;
+use Test::Builder::Module;
+
+my $TB = Test::Builder->create;
+$TB->plan( tests => 1 );
+$TB->level(0);
+
+$TB->is_eq( Test::Builder::Module->builder->exported_to,
+ undef,
+ 'using Test::Builder::Module does not set exported_to()'
+);
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_01basic.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_01basic.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_01basic.t 2005-10-09 21:11:02.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_01basic.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::Builder::Tester tests => 9;
use Test::More;
@@ -29,7 +22,7 @@ ok(2,"two");
test_test("multiple tests");
test_out("not ok 1 - should fail");
-test_err("# Failed test ($0 at line 35)");
+test_err("# Failed test ($0 at line 28)");
test_err("# got: 'foo'");
test_err("# expected: 'bar'");
is("foo","bar","should fail");
@@ -53,7 +46,7 @@ test_test("testing failing on the same l
test_out("not ok 1 - name # TODO Something");
-test_err("# Failed (TODO) test ($0 at line 59)");
+test_err("# Failed (TODO) test ($0 at line 52)");
TODO: {
local $TODO = "Something";
fail("name");
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_02fhrestore.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_02fhrestore.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_02fhrestore.t 2005-10-09 17:56:44.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_02fhrestore.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::Builder::Tester tests => 4;
use Test::More;
use Symbol;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_03die.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_03die.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_03die.t 2005-10-09 17:56:56.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_03die.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::Builder::Tester tests => 1;
use Test::More;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_04line_num.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_04line_num.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_04line_num.t 2005-10-09 21:13:35.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_04line_num.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,15 +1,8 @@
#!/usr/bin/perl
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::More tests => 3;
use Test::Builder::Tester;
-is(line_num(),13,"normal line num");
-is(line_num(-1),13,"line number minus one");
-is(line_num(+2),17,"line number plus two");
+is(line_num(),6,"normal line num");
+is(line_num(-1),6,"line number minus one");
+is(line_num(+2),10,"line number plus two");
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_05faildiag.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_05faildiag.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_05faildiag.t 2005-10-09 17:57:21.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_05faildiag.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::Builder::Tester tests => 5;
use Test::More;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_06errormess.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_06errormess.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_06errormess.t 2005-10-09 17:57:34.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_06errormess.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl -w
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::More tests => 8;
use Symbol;
use Test::Builder;
@@ -25,8 +18,8 @@ my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
-my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
-my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
# ooooh, use the test suite
my $t = Test::Builder->new;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/tbt_07args.t /home/marca/Desktop/Test-Simple-0.78/t/tbt_07args.t
--- perl-5.8.8/lib/Test/Simple/t/tbt_07args.t 2005-10-09 17:57:49.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/tbt_07args.t 2006-09-04 10:23:12.000000000 +0200
@@ -1,12 +1,5 @@
#!/usr/bin/perl -w
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
use Test::More tests => 18;
use Symbol;
use Test::Builder;
@@ -25,8 +18,8 @@ my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
-my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
-my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
# ooooh, use the test suite
my $t = Test::Builder->new;
diff -uprNB perl-5.8.8/lib/Test/Simple/t/threads.t /home/marca/Desktop/Test-Simple-0.78/t/threads.t
--- perl-5.8.8/lib/Test/Simple/t/threads.t 2004-12-01 21:26:55.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/threads.t 2006-09-04 10:36:16.000000000 +0200
@@ -9,10 +9,10 @@ BEGIN {
use Config;
BEGIN {
- unless ( $] >= 5.008 && $Config{'useithreads'} &&
+ unless ( $] >= 5.008001 && $Config{'useithreads'} &&
eval { require threads; 'threads'->import; 1; })
{
- print "1..0 # Skip: no threads\n";
+ print "1..0 # Skip: no working threads\n";
exit 0;
}
}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/todo.t /home/marca/Desktop/Test-Simple-0.78/t/todo.t
--- perl-5.8.8/lib/Test/Simple/t/todo.t 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/t/todo.t 2008-02-27 10:37:18.000000000 +0100
@@ -9,7 +9,7 @@ BEGIN {
use Test::More;
-plan tests => 18;
+plan tests => 19;
$Why = 'Just testing the todo interface.';
@@ -69,11 +69,20 @@ TODO: {
# perl gets the line number a little wrong on the first
# statement inside a block.
1 == 1;
-#line 82
+#line 73
todo_skip "Just testing todo_skip";
fail("So very failed");
}
is( $warning, "todo_skip() needs to know \$how_many tests are in the ".
- "block at $0 line 82\n",
+ "block at $0 line 73\n",
'todo_skip without $how_many warning' );
}
+
+
+TODO: {
+ Test::More->builder->exported_to("Wibble");
+
+ local $TODO = "testing \$TODO with an incorrect exported_to()";
+
+ fail("Just testing todo");
+}
diff -uprNB perl-5.8.8/lib/Test/Simple/t/try.t /home/marca/Desktop/Test-Simple-0.78/t/try.t
--- perl-5.8.8/lib/Test/Simple/t/try.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/try.t 2007-02-11 16:59:26.000000000 +0100
@@ -0,0 +1,35 @@
+#!perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More 'no_plan';
+
+require Test::Builder;
+my $tb = Test::Builder->new;
+
+local $SIG{__DIE__} = sub { fail("DIE handler called: @_") };
+
+# These should not change;
+local $@ = 42;
+local $! = 23;
+
+is $tb->_try(sub { 2 }), 2;
+is $tb->_try(sub { return '' }), '';
+
+is $tb->_try(sub { die; }), undef;
+
+is_deeply [$tb->_try(sub { die "Foo\n" }, undef)],
+ [undef, "Foo\n"];
+
+is $@, 42;
+cmp_ok $!, '==', 23;
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Simple/t/utf8.t /home/marca/Desktop/Test-Simple-0.78/t/utf8.t
--- perl-5.8.8/lib/Test/Simple/t/utf8.t 1970-01-01 01:00:00.000000000 +0100
+++ /home/marca/Desktop/Test-Simple-0.78/t/utf8.t 2008-02-27 10:54:27.000000000 +0100
@@ -0,0 +1,61 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use warnings;
+
+
+my $have_perlio;
+BEGIN {
+ # All together so Test::More sees the open discipline
+ $have_perlio = eval q[
+ use PerlIO;
+ use open ':std', ':locale';
+ use Test::More;
+ 1;
+ ];
+}
+#use Test::More tests => 5;
+use Test::More skip_all => 'Not yet implemented';
+
+SKIP: {
+ skip( "Need PerlIO for this feature", 3 )
+ unless $have_perlio;
+
+ my %handles = (
+ output => \*STDOUT,
+ failure_output => \*STDERR,
+ todo_output => \*STDOUT
+ );
+
+ for my $method (keys %handles) {
+ my $src = $handles{$method};
+
+ my $dest = Test::More->builder->$method;
+
+ is_deeply [PerlIO::get_layers($dest)],
+ [PerlIO::get_layers($src)],
+ "layers copied to $method";
+ }
+}
+
+SKIP: {
+ skip( "Can't test in general because their locale is unknown", 2 )
+ unless $ENV{AUTHOR_TESTING};
+
+ my $uni = "\x{11e}";
+
+ my @warnings;
+ local $SIG{__WARN__} = sub {
+ push @warnings, @_;
+ };
+
+ is( $uni, $uni, "Testing $uni" );
+ is_deeply( \@warnings, [] );
+}
\ No newline at end of file
diff -uprNB perl-5.8.8/lib/Test/Builder/Module.pm /home/marca/Desktop/Test-Simple-0.78/lib/Test/Builder/Module.pm
--- perl-5.8.8/lib/Test/Builder/Module.pm 2005-09-26 18:58:26.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/lib/Test/Builder/Module.pm 2008-02-27 11:01:46.000000000 +0100
@@ -1,13 +1,13 @@
package Test::Builder::Module;
+use strict;
+
use Test::Builder;
require Exporter;
-@ISA = qw(Exporter);
+our @ISA = qw(Exporter);
-$VERSION = '0.02';
-
-use strict;
+our $VERSION = '0.78';
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
@@ -83,6 +83,9 @@ import_extra().
sub import {
my($class) = shift;
+
+ # Don't run all this when loading ourself.
+ return 1 if $class eq 'Test::Builder::Module';
my $test = $class->builder;
diff -uprNB perl-5.8.8/lib/Test/Builder/Tester.pm /home/marca/Desktop/Test-Simple-0.78/lib/Test/Builder/Tester.pm
--- perl-5.8.8/lib/Test/Builder/Tester.pm 2005-10-08 10:24:18.000000000 +0200
+++ /home/marca/Desktop/Test-Simple-0.78/lib/Test/Builder/Tester.pm 2008-02-27 11:01:52.000000000 +0100
@@ -1,8 +1,7 @@
package Test::Builder::Tester;
use strict;
-use vars qw(@EXPORT $VERSION @ISA);
-$VERSION = "1.02";
+our $VERSION = "1.13";
use Test::Builder;
use Symbol;
@@ -56,9 +55,9 @@ my $t = Test::Builder->new;
###
use Exporter;
-@ISA = qw(Exporter);
+our @ISA = qw(Exporter);
-@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
# _export_to_level and import stolen directly from Test::More. I am
# the king of cargo cult programming ;-)
@@ -102,8 +101,8 @@ my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
-my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
-my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
####
# exported functions
@@ -154,7 +153,7 @@ sub _start_testing
$t->no_ending(1);
}
-=head2 Methods
+=head2 Functions
These are the six methods that are exported as default.
@@ -188,7 +187,7 @@ output filehandles)
=cut
-sub test_out(@)
+sub test_out
{
# do we need to do any setup?
_start_testing() unless $testing;
@@ -196,7 +195,7 @@ sub test_out(@)
$out->expect(@_)
}
-sub test_err(@)
+sub test_err
{
# do we need to do any setup?
_start_testing() unless $testing;
@@ -214,7 +213,7 @@ so
test_err("# Failed test ($0 at line ".line_num(+1).")");
-C<test_fail> exists as a convenience method that can be called
+C<test_fail> exists as a convenience function that can be called
instead. It takes one argument, the offset from the current line that
the line that causes the fail is on.
@@ -376,7 +375,7 @@ sub test_test
A utility function that returns the line number that the function was
called on. You can pass it an offset which will be added to the
result. This is very useful for working out the correct text of
-diagnostic methods that contain line numbers.
+diagnostic functions that contain line numbers.
Essentially this is the same as the C<__LINE__> macro, but the
C<line_num(+3)> idiom is arguably nicer.
@@ -442,10 +441,10 @@ sub color
=head1 BUGS
-Calls B<Test::Builder>'s C<no_ending> method turning off the ending
-tests. This is needed as otherwise it will trip out because we've run
-more tests than we strictly should have and it'll register any
-failures we had that we were testing for as real failures.
+Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+This is needed as otherwise it will trip out because we've run more
+tests than we strictly should have and it'll register any failures we
+had that we were testing for as real failures.
The color function doesn't work unless B<Term::ANSIColor> is installed
and is compatible with your terminal.
@@ -485,7 +484,7 @@ L<Test::Builder>, L<Test::Builder::Teste
####################################################################
# Helper class that is used to remember expected and received data
-package Test::Tester::Tie;
+package Test::Builder::Tester::Tie;
##
# add line(s) to be expected
@@ -497,17 +496,17 @@ sub expect
my @checks = @_;
foreach my $check (@checks) {
$check = $self->_translate_Failed_check($check);
- push @{$self->[2]}, ref $check ? $check : "$check\n";
+ push @{$self->{wanted}}, ref $check ? $check : "$check\n";
}
}
-sub _translate_Failed_check
+sub _translate_Failed_check
{
my($self, $check) = @_;
- if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\z/ ) {
- $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/;
+ if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
+ $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
}
return $check;
@@ -524,10 +523,10 @@ sub check
# turn off warnings as these might be undef
local $^W = 0;
- my @checks = @{$self->[2]};
- my $got = $self->[1];
+ my @checks = @{$self->{wanted}};
+ my $got = $self->{got};
foreach my $check (@checks) {
- $check = qr/^\Q$check\E/ unless ref $check;
+ $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check);
return 0 unless $got =~ s/^$check//;
}
@@ -549,36 +548,36 @@ sub complaint
if (Test::Builder::Tester::color)
{
# get color
- eval "require Term::ANSIColor";
+ eval { require Term::ANSIColor };
unless ($@)
{
- # colours
+ # colours
- my $green = Term::ANSIColor::color("black").
- Term::ANSIColor::color("on_green");
+ my $green = Term::ANSIColor::color("black").
+ Term::ANSIColor::color("on_green");
my $red = Term::ANSIColor::color("black").
Term::ANSIColor::color("on_red");
- my $reset = Term::ANSIColor::color("reset");
+ my $reset = Term::ANSIColor::color("reset");
- # work out where the two strings start to differ
- my $char = 0;
- $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
-
- # get the start string and the two end strings
- my $start = $green . substr($wanted, 0, $char);
- my $gotend = $red . substr($got , $char) . $reset;
- my $wantedend = $red . substr($wanted, $char) . $reset;
-
- # make the start turn green on and off
- $start =~ s/\n/$reset\n$green/g;
-
- # make the ends turn red on and off
- $gotend =~ s/\n/$reset\n$red/g;
- $wantedend =~ s/\n/$reset\n$red/g;
-
- # rebuild the strings
- $got = $start . $gotend;
- $wanted = $start . $wantedend;
+ # work out where the two strings start to differ
+ my $char = 0;
+ $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
+
+ # get the start string and the two end strings
+ my $start = $green . substr($wanted, 0, $char);
+ my $gotend = $red . substr($got , $char) . $reset;
+ my $wantedend = $red . substr($wanted, $char) . $reset;
+
+ # make the start turn green on and off
+ $start =~ s/\n/$reset\n$green/g;
+
+ # make the ends turn red on and off
+ $gotend =~ s/\n/$reset\n$red/g;
+ $wantedend =~ s/\n/$reset\n$red/g;
+
+ # rebuild the strings
+ $got = $start . $gotend;
+ $wanted = $start . $wantedend;
}
}
@@ -592,26 +591,30 @@ sub complaint
sub reset
{
my $self = shift;
- @$self = ($self->[0], '', []);
+ %$self = (
+ type => $self->{type},
+ got => '',
+ wanted => [],
+ );
}
sub got
{
my $self = shift;
- return $self->[1];
+ return $self->{got};
}
sub wanted
{
my $self = shift;
- return $self->[2];
+ return $self->{wanted};
}
sub type
{
my $self = shift;
- return $self->[0];
+ return $self->{type};
}
###
@@ -620,13 +623,16 @@ sub type
sub PRINT {
my $self = shift;
- $self->[1] .= join '', @_;
+ $self->{got} .= join '', @_;
}
sub TIEHANDLE {
my($class, $type) = @_;
- my $self = bless [$type], $class;
+ my $self = bless {
+ type => $type
+ }, $class;
+
$self->reset;
return $self;