Change 33969 by [EMAIL PROTECTED] on 2008/05/31 15:46:38
Integrate:
[ 33340]
Fix Module-Build test that has been failing on Win32
since the upgrade of Test-Harness at #32659
[ 33391]
Upgrade to Test-Simple-0.75
[ 33394]
Upgrade to Test-Simple-0.78
[ 33395]
Hmmm...lib/Test/Builder.pm didn't get updated corectly. Unfortunately,
the tests didn't seem to catch this.
[ 33397]
Re-apply change #32880
[ 33398]
Context fix to make the test pass
[ 33688]
Sync with CPAN's version of the More.t test in Test::Simple
and delete duplicated test module Dummy.pm. (test now
expected to fail)
[ 33689]
Adapt properly More.t to run in the core
(like Module::Build does, for example)
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#36 integrate
... //depot/maint-5.10/perl/lib/Module/Build.pm#2 integrate
... //depot/maint-5.10/perl/lib/Module/Build/t/compat.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Builder.pm#4 integrate
... //depot/maint-5.10/perl/lib/Test/Builder/Module.pm#3 integrate
... //depot/maint-5.10/perl/lib/Test/Builder/Tester.pm#3 integrate
... //depot/maint-5.10/perl/lib/Test/More.pm#3 integrate
... //depot/maint-5.10/perl/lib/Test/Simple.pm#3 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/BEGIN_require_ok.t#1 branch
... //depot/maint-5.10/perl/lib/Test/Simple/t/More.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/dont_overwrite_die_handler.t#1
branch
... //depot/maint-5.10/perl/lib/Test/Simple/t/exit.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/filehandles.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/is_deeply_with_threads.t#2
integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/maybe_regex.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/reset.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t#1
branch
... //depot/maint-5.10/perl/lib/Test/Simple/t/todo.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Simple/t/utf8.t#1 branch
... //depot/maint-5.10/perl/t/lib/Dummy.pm#2 delete
... //depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/death.plx#2 integrate
...
//depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/death_with_handler.plx#1
branch
...
//depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx#2
integrate
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#36 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#35~33967~ 2008-05-31 07:49:10.000000000 -0700
+++ perl/MANIFEST 2008-05-31 08:46:38.000000000 -0700
@@ -2723,6 +2723,7 @@
lib/Test/Simple/t/00test_harness_check.t Test::Simple test
lib/Test/Simple/t/bad_plan.t Test::Builder plan() test
lib/Test/Simple/t/bail_out.t Test::Builder BAIL_OUT test
+lib/Test/Simple/t/BEGIN_require_ok.t Test::More require_ok() testing
lib/Test/Simple/t/BEGIN_use_ok.t Test::More use_ok() testing
lib/Test/Simple/t/buffer.t Test::Builder buffering test
lib/Test/Simple/t/Builder.t Test::Builder tests
@@ -2733,6 +2734,7 @@
lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests
lib/Test/Simple/t/details.t Test::Builder tests
lib/Test/Simple/t/diag.t Test::More diag() test
+lib/Test/Simple/t/dont_overwrite_die_handler.t Test::More tests
lib/Test/Simple/t/eq_set.t Test::Simple test
lib/Test/Simple/t/exit.t Test::Simple test, exit codes
lib/Test/Simple/t/extra_one.t Test::Simple test
@@ -2776,6 +2778,7 @@
lib/Test/Simple/t/simple.t Test::Simple test, basic stuff
lib/Test/Simple/t/skipall.t Test::More test, skip all tests
lib/Test/Simple/t/skip.t Test::More test, SKIP tests
+lib/Test/Simple/t/tbm_doesnt_set_exported_to.t Test::Builder::Module test
lib/Test/Simple/t/tbt_01basic.t Test::Builder::Tester test
lib/Test/Simple/t/tbt_02fhrestore.t Test::Builder::Tester test
lib/Test/Simple/t/tbt_03die.t Test::Builder::Tester test
@@ -2790,6 +2793,7 @@
lib/Test/Simple/t/undef.t Test::More test, undefs don't cause warnings
lib/Test/Simple/t/useing.t Test::More test, compile test
lib/Test/Simple/t/use_ok.t Test::More test, use_ok()
+lib/Test/Simple/t/utf8.t Test::More test
lib/Test/t/05_about_verbose.t See if Test works
lib/Test/t/fail.t See if Test works
lib/Test/t/mix.t See if Test works
@@ -3689,6 +3693,7 @@
t/lib/strict/vars Tests of "use strict 'vars'" for strict.t
t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple
t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t
+t/lib/Test/Simple/sample_tests/death_with_handler.plx for exit.t
t/lib/Test/Simple/sample_tests/death.plx for exit.t
t/lib/Test/Simple/sample_tests/exit.plx for exit.t
t/lib/Test/Simple/sample_tests/extras.plx for exit.t
==== //depot/maint-5.10/perl/lib/Module/Build.pm#2 (text) ====
Index: perl/lib/Module/Build.pm
--- perl/lib/Module/Build.pm#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/lib/Module/Build.pm 2008-05-31 08:46:38.000000000 -0700
@@ -15,7 +15,7 @@
use vars qw($VERSION @ISA);
@ISA = qw(Module::Build::Base);
-$VERSION = '0.2808_01';
+$VERSION = '0.2808_02';
$VERSION = eval $VERSION;
# Okay, this is the brute-force method of finding out what kind of
==== //depot/maint-5.10/perl/lib/Module/Build/t/compat.t#2 (text) ====
Index: perl/lib/Module/Build/t/compat.t
--- perl/lib/Module/Build/t/compat.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/Module/Build/t/compat.t 2008-05-31 08:46:38.000000000 -0700
@@ -174,7 +174,8 @@
$output = stdout_of( sub { $ran_ok = $mb->do_system(@make, 'test',
'TEST_VERBOSE=0') } );
ok $ran_ok, "make test without verbose ran ok";
$output =~ s/^/# /gm; # Don't confuse our own test output
- like $output, qr/(?:# .+basic\.+ok\s+(?:[\d.]+\s*m?s\s*)?)# All tests/,
+ like $output,
+ qr/(?:# .+basic\.+ok\s+(?:[\d.]+\s*m?s\s*)?(?:# \[[\d:]+\]\s*)?)# All
tests/,
'Should be non-verbose';
$mb->delete_filetree($libdir);
==== //depot/maint-5.10/perl/lib/Test/Builder.pm#4 (text) ====
Index: perl/lib/Test/Builder.pm
--- perl/lib/Test/Builder.pm#3~33968~ 2008-05-31 08:38:17.000000000 -0700
+++ perl/lib/Test/Builder.pm 2008-05-31 08:46:38.000000000 -0700
@@ -1,15 +1,10 @@
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.74_1';
-$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+our $VERSION = '0.78_01';
+$VERSION = eval { $VERSION }; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
@@ -73,28 +68,15 @@
=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);
}
@@ -177,7 +159,6 @@
# 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} = $$;
@@ -196,9 +177,11 @@
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
+ $self->{TODO} = undef;
+
$self->_dup_stdhandles unless $^C;
- return undef;
+ return;
}
=back
@@ -210,25 +193,6 @@
=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');
@@ -360,6 +324,29 @@
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
@@ -401,9 +388,12 @@
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;
@@ -448,13 +438,14 @@
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[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file 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;
@@ -584,6 +575,7 @@
}
}
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
@@ -705,7 +697,8 @@
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;";
@@ -730,6 +723,8 @@
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
@@ -941,7 +936,18 @@
}
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) = @_;
@@ -960,7 +966,8 @@
local($@, $!, $SIG{__DIE__}); # isolate eval
- # 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" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
@@ -974,6 +981,8 @@
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'
@@ -1149,7 +1158,7 @@
return $self->{$attribute};
};
- no strict 'refs';
+ no strict 'refs'; ## no critic
*{__PACKAGE__.'::'.$method} = $code;
}
@@ -1336,10 +1345,9 @@
$fh = $file_or_fh;
}
else {
- $fh = do { local *FH };
- open $fh, ">$file_or_fh" or
+ open $fh, ">", $file_or_fh or
$self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
+ _autoflush($fh);
}
return $fh;
@@ -1354,6 +1362,7 @@
}
+my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
@@ -1361,28 +1370,46 @@
# 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);
@@ -1562,9 +1589,10 @@
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
@@ -1575,10 +1603,12 @@
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;
}
@@ -1591,6 +1621,8 @@
Like the normal caller(), except it reports according to your level().
+C<$height> will be added to the level().
+
=cut
sub caller {
@@ -1675,35 +1707,27 @@
=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.
@@ -1753,7 +1777,7 @@
FAIL
}
- if( $self->{Test_Died} ) {
+ if( $real_exit_code ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
@@ -1777,7 +1801,7 @@
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
==== //depot/maint-5.10/perl/lib/Test/Builder/Module.pm#3 (text) ====
Index: perl/lib/Test/Builder/Module.pm
--- perl/lib/Test/Builder/Module.pm#2~33108~ 2008-01-29 09:37:50.000000000
-0800
+++ perl/lib/Test/Builder/Module.pm 2008-05-31 08:46:38.000000000 -0700
@@ -1,13 +1,13 @@
package Test::Builder::Module;
+use strict;
+
use Test::Builder;
require Exporter;
[EMAIL PROTECTED] = qw(Exporter);
+our @ISA = qw(Exporter);
-$VERSION = '0.74';
-
-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 @@
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;
==== //depot/maint-5.10/perl/lib/Test/Builder/Tester.pm#3 (text) ====
Index: perl/lib/Test/Builder/Tester.pm
--- perl/lib/Test/Builder/Tester.pm#2~33108~ 2008-01-29 09:37:50.000000000
-0800
+++ perl/lib/Test/Builder/Tester.pm 2008-05-31 08:46:38.000000000 -0700
@@ -1,8 +1,7 @@
package Test::Builder::Tester;
use strict;
-use vars qw(@EXPORT $VERSION @ISA);
-$VERSION = "1.11";
+our $VERSION = "1.13";
use Test::Builder;
use Symbol;
@@ -56,9 +55,9 @@
###
use Exporter;
[EMAIL PROTECTED] = qw(Exporter);
+our @ISA = qw(Exporter);
[EMAIL PROTECTED] = 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 ;-)
@@ -188,7 +187,7 @@
=cut
-sub test_out(@)
+sub test_out
{
# do we need to do any setup?
_start_testing() unless $testing;
@@ -196,7 +195,7 @@
$out->expect(@_)
}
-sub test_err(@)
+sub test_err
{
# do we need to do any setup?
_start_testing() unless $testing;
@@ -549,36 +548,36 @@
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;
}
}
==== //depot/maint-5.10/perl/lib/Test/More.pm#3 (text) ====
Index: perl/lib/Test/More.pm
--- perl/lib/Test/More.pm#2~33108~ 2008-01-29 09:37:50.000000000 -0800
+++ perl/lib/Test/More.pm 2008-05-31 08:46:38.000000000 -0700
@@ -1,7 +1,6 @@
package Test::More;
-use 5.004;
-
+use 5.006;
use strict;
@@ -16,7 +15,7 @@
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.74';
+$VERSION = '0.78';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -31,7 +30,7 @@
plan
can_ok isa_ok
diag
- BAIL_OUT
+ BAIL_OUT
);
@@ -659,30 +658,28 @@
my($pack,$filename,$line) = caller;
- # Work around a glitch in $@ and eval
- my $eval_error;
- {
- local($@,$!,$SIG{__DIE__}); # isolate eval
-
- 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;
+ my $code;
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ $code = <<USE;
package $pack;
use $module $imports[0];
+1;
USE
- }
- else {
- eval <<USE;
+ }
+ else {
+ $code = <<USE;
package $pack;
-use $module [EMAIL PROTECTED];
+use $module [EMAIL PROTECTED];
+1;
USE
- }
- $eval_error = $@;
}
- my $ok = $tb->ok( !$eval_error, "use $module;" );
+ my($eval_result, $eval_error) = _eval($code, [EMAIL PROTECTED]);
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
unless( $ok ) {
chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
@@ -697,6 +694,20 @@
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);
@@ -716,20 +727,20 @@
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
- local($!, $@, $SIG{__DIE__}); # isolate eval
- local $SIG{__DIE__};
- 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
}
@@ -1443,7 +1454,7 @@
=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
==== //depot/maint-5.10/perl/lib/Test/Simple.pm#3 (text) ====
Index: perl/lib/Test/Simple.pm
--- perl/lib/Test/Simple.pm#2~33108~ 2008-01-29 09:37:50.000000000 -0800
+++ perl/lib/Test/Simple.pm 2008-05-31 08:46:38.000000000 -0700
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.74';
+$VERSION = '0.78';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
==== //depot/maint-5.10/perl/lib/Test/Simple/t/BEGIN_require_ok.t#1 (text) ====
Index: perl/lib/Test/Simple/t/BEGIN_require_ok.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/Test/Simple/t/BEGIN_require_ok.t 2008-05-31 08:46:38.000000000
-0700
@@ -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/';
==== //depot/maint-5.10/perl/lib/Test/Simple/t/More.t#2 (text) ====
Index: perl/lib/Test/Simple/t/More.t
--- perl/lib/Test/Simple/t/More.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/Test/Simple/t/More.t 2008-05-31 08:46:38.000000000 -0700
@@ -3,7 +3,7 @@
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
- @INC = qw(../lib lib);
+ @INC = qw(../lib ../lib/Test/Simple/t/lib);
}
}
@@ -17,7 +17,7 @@
$! = $Errno;
use_ok('Dummy');
-is( $Dummy::VERSION, '5.562', 'use_ok() loads a module' );
+is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' );
require_ok('Test::More');
==== //depot/maint-5.10/perl/lib/Test/Simple/t/dont_overwrite_die_handler.t#1
(text) ====
Index: perl/lib/Test/Simple/t/dont_overwrite_die_handler.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/Test/Simple/t/dont_overwrite_die_handler.t 2008-05-31
08:46:38.000000000 -0700
@@ -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';
==== //depot/maint-5.10/perl/lib/Test/Simple/t/exit.t#2 (text) ====
Index: perl/lib/Test/Simple/t/exit.t
--- perl/lib/Test/Simple/t/exit.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/Test/Simple/t/exit.t 2008-05-31 08:46:38.000000000 -0700
@@ -25,18 +25,9 @@
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 @@
'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 @@
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)");
}
==== //depot/maint-5.10/perl/lib/Test/Simple/t/filehandles.t#2 (text) ====
Index: perl/lib/Test/Simple/t/filehandles.t
--- perl/lib/Test/Simple/t/filehandles.t#1~32694~ 2007-12-22
01:23:09.000000000 -0800
+++ perl/lib/Test/Simple/t/filehandles.t 2008-05-31 08:46:38.000000000
-0700
@@ -3,19 +3,16 @@
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
- @INC = '../lib';
+ @INC = ('../lib', 'lib');
}
}
+use lib 't/lib';
use Test::More tests => 1;
+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 }
==== //depot/maint-5.10/perl/lib/Test/Simple/t/is_deeply_with_threads.t#2
(text) ====
Index: perl/lib/Test/Simple/t/is_deeply_with_threads.t
--- perl/lib/Test/Simple/t/is_deeply_with_threads.t#1~32694~ 2007-12-22
01:23:09.000000000 -0800
+++ perl/lib/Test/Simple/t/is_deeply_with_threads.t 2008-05-31
08:46:38.000000000 -0700
@@ -22,12 +22,17 @@
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 + 5;
+plan tests => $Num_Threads * 100 + 6;
sub do_one_thread {
@@ -56,3 +61,5 @@
my $rc = $t->join();
cmp_ok( $rc, '==', 42, "threads exit status is $rc" );
}
+
+pass("End of test");
==== //depot/maint-5.10/perl/lib/Test/Simple/t/maybe_regex.t#2 (text) ====
Index: perl/lib/Test/Simple/t/maybe_regex.t
--- perl/lib/Test/Simple/t/maybe_regex.t#1~32694~ 2007-12-22
01:23:09.000000000 -0800
+++ perl/lib/Test/Simple/t/maybe_regex.t 2008-05-31 08:46:38.000000000
-0700
@@ -11,22 +11,24 @@
}
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' );
}
{
==== //depot/maint-5.10/perl/lib/Test/Simple/t/reset.t#2 (text) ====
Index: perl/lib/Test/Simple/t/reset.t
--- perl/lib/Test/Simple/t/reset.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/Test/Simple/t/reset.t 2008-05-31 08:46:38.000000000 -0700
@@ -16,6 +16,11 @@
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->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' );
==== //depot/maint-5.10/perl/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t#1
(text) ====
Index: perl/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 2008-05-31
08:46:38.000000000 -0700
@@ -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
==== //depot/maint-5.10/perl/lib/Test/Simple/t/todo.t#2 (text) ====
Index: perl/lib/Test/Simple/t/todo.t
--- perl/lib/Test/Simple/t/todo.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/Test/Simple/t/todo.t 2008-05-31 08:46:38.000000000 -0700
@@ -9,7 +9,7 @@
use Test::More;
-plan tests => 18;
+plan tests => 19;
$Why = 'Just testing the todo interface.';
@@ -69,11 +69,20 @@
# 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");
+}
==== //depot/maint-5.10/perl/lib/Test/Simple/t/utf8.t#1 (text) ====
Index: perl/lib/Test/Simple/t/utf8.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/Test/Simple/t/utf8.t 2008-05-31 08:46:38.000000000 -0700
@@ -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( [EMAIL PROTECTED], [] );
+}
\ No newline at end of file
==== //depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/death.plx#2 (text)
====
Index: perl/t/lib/Test/Simple/sample_tests/death.plx
--- perl/t/lib/Test/Simple/sample_tests/death.plx#1~32694~ 2007-12-22
01:23:09.000000000 -0800
+++ perl/t/lib/Test/Simple/sample_tests/death.plx 2008-05-31
08:46:38.000000000 -0700
@@ -4,10 +4,12 @@
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
+require Dev::Null;
+
Test::Simple->import(tests => 5);
-close STDERR;
+tie *STDERR, 'Dev::Null';
ok(1);
ok(1);
ok(1);
-die "Knife?";
+die "This is a test";
====
//depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/death_with_handler.plx#1
(text) ====
Index: perl/t/lib/Test/Simple/sample_tests/death_with_handler.plx
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/lib/Test/Simple/sample_tests/death_with_handler.plx 2008-05-31
08:46:38.000000000 -0700
@@ -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";
====
//depot/maint-5.10/perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx#2
(text) ====
Index: perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx
--- perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx#1~32694~
2007-12-22 01:23:09.000000000 -0800
+++ perl/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2008-05-31
08:46:38.000000000 -0700
@@ -5,7 +5,9 @@
my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
-close STDERR;
+
+require Dev::Null;
+tie *STDERR, 'Dev::Null';
ok(1);
ok(1);
@@ -13,4 +15,4 @@
ok(1);
ok(1);
-die "Almost there...";
+die "This is a test";
End of Patch.
