8178 lines
215 KiB
Diff
8178 lines
215 KiB
Diff
Update to 0.92; patch by Iain Arnell <iarnell@gmail.com> (BZ#519417)
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Test/Builder/Module.pm perl-5.10.0/lib/Test/Builder/Module.pm
|
|
--- perl-5.10.0.orig/lib/Test/Builder/Module.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Builder/Module.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,24 +1,24 @@
|
|
package Test::Builder::Module;
|
|
|
|
+use strict;
|
|
+
|
|
use Test::Builder;
|
|
|
|
require Exporter;
|
|
-@ISA = qw(Exporter);
|
|
+our @ISA = qw(Exporter);
|
|
|
|
-$VERSION = '0.72';
|
|
-
|
|
-use strict;
|
|
+our $VERSION = '0.92';
|
|
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
|
|
# 5.004's Exporter doesn't have export_to_level.
|
|
my $_export_to_level = sub {
|
|
- my $pkg = shift;
|
|
- my $level = shift;
|
|
- (undef) = shift; # redundant arg
|
|
- my $callpkg = caller($level);
|
|
- $pkg->export($callpkg, @_);
|
|
+ my $pkg = shift;
|
|
+ my $level = shift;
|
|
+ (undef) = shift; # redundant arg
|
|
+ my $callpkg = caller($level);
|
|
+ $pkg->export( $callpkg, @_ );
|
|
};
|
|
|
|
-
|
|
=head1 NAME
|
|
|
|
Test::Builder::Module - Base class for test modules
|
|
@@ -84,33 +84,35 @@
|
|
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;
|
|
|
|
my $caller = caller;
|
|
|
|
$test->exported_to($caller);
|
|
|
|
- $class->import_extra(\@_);
|
|
- my(@imports) = $class->_strip_imports(\@_);
|
|
+ $class->import_extra( \@_ );
|
|
+ my(@imports) = $class->_strip_imports( \@_ );
|
|
|
|
$test->plan(@_);
|
|
|
|
- $class->$_export_to_level(1, $class, @imports);
|
|
+ $class->$_export_to_level( 1, $class, @imports );
|
|
}
|
|
|
|
-
|
|
sub _strip_imports {
|
|
my $class = shift;
|
|
my $list = shift;
|
|
|
|
my @imports = ();
|
|
my @other = ();
|
|
- my $idx = 0;
|
|
+ my $idx = 0;
|
|
while( $idx <= $#{$list} ) {
|
|
my $item = $list->[$idx];
|
|
|
|
if( defined $item and $item eq 'import' ) {
|
|
- push @imports, @{$list->[$idx+1]};
|
|
+ push @imports, @{ $list->[ $idx + 1 ] };
|
|
$idx++;
|
|
}
|
|
else {
|
|
@@ -125,7 +127,6 @@
|
|
return @imports;
|
|
}
|
|
|
|
-
|
|
=head3 import_extra
|
|
|
|
Your::Module->import_extra(\@import_args);
|
|
@@ -143,8 +144,7 @@
|
|
|
|
=cut
|
|
|
|
-sub import_extra {}
|
|
-
|
|
+sub import_extra { }
|
|
|
|
=head2 Builder
|
|
|
|
@@ -178,5 +178,4 @@
|
|
return Test::Builder->new;
|
|
}
|
|
|
|
-
|
|
1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Builder/Tester/Color.pm perl-5.10.0/lib/Test/Builder/Tester/Color.pm
|
|
--- perl-5.10.0.orig/lib/Test/Builder/Tester/Color.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Builder/Tester/Color.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,9 +1,11 @@
|
|
package Test::Builder::Tester::Color;
|
|
|
|
use strict;
|
|
+our $VERSION = "1.18";
|
|
|
|
require Test::Builder::Tester;
|
|
|
|
+
|
|
=head1 NAME
|
|
|
|
Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
|
|
@@ -25,8 +27,7 @@
|
|
|
|
=cut
|
|
|
|
-sub import
|
|
-{
|
|
+sub import {
|
|
Test::Builder::Tester::color(1);
|
|
}
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Test/Builder/Tester.pm perl-5.10.0/lib/Test/Builder/Tester.pm
|
|
--- perl-5.10.0.orig/lib/Test/Builder/Tester.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Builder/Tester.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,8 +1,7 @@
|
|
package Test::Builder::Tester;
|
|
|
|
use strict;
|
|
-use vars qw(@EXPORT $VERSION @ISA);
|
|
-$VERSION = "1.09";
|
|
+our $VERSION = "1.18";
|
|
|
|
use Test::Builder;
|
|
use Symbol;
|
|
@@ -56,21 +55,20 @@
|
|
###
|
|
|
|
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 ;-)
|
|
|
|
# 5.004's Exporter doesn't have export_to_level.
|
|
-sub _export_to_level
|
|
-{
|
|
- my $pkg = shift;
|
|
- my $level = shift;
|
|
- (undef) = shift; # XXX redundant arg
|
|
- my $callpkg = caller($level);
|
|
- $pkg->export($callpkg, @_);
|
|
+sub _export_to_level {
|
|
+ my $pkg = shift;
|
|
+ my $level = shift;
|
|
+ (undef) = shift; # XXX redundant arg
|
|
+ my $callpkg = caller($level);
|
|
+ $pkg->export( $callpkg, @_ );
|
|
}
|
|
|
|
sub import {
|
|
@@ -83,14 +81,14 @@
|
|
$t->plan(@plan);
|
|
|
|
my @imports = ();
|
|
- foreach my $idx (0..$#plan) {
|
|
+ foreach my $idx ( 0 .. $#plan ) {
|
|
if( $plan[$idx] eq 'import' ) {
|
|
- @imports = @{$plan[$idx+1]};
|
|
+ @imports = @{ $plan[ $idx + 1 ] };
|
|
last;
|
|
}
|
|
}
|
|
|
|
- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
|
|
+ __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports );
|
|
}
|
|
|
|
###
|
|
@@ -124,8 +122,7 @@
|
|
my $original_harness_env;
|
|
|
|
# function that starts testing and redirects the filehandles for now
|
|
-sub _start_testing
|
|
-{
|
|
+sub _start_testing {
|
|
# even if we're running under Test::Harness pretend we're not
|
|
# for now. This needed so Test::Builder doesn't add extra spaces
|
|
$original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
|
|
@@ -146,7 +143,7 @@
|
|
$err->reset();
|
|
|
|
# remeber that we're testing
|
|
- $testing = 1;
|
|
+ $testing = 1;
|
|
$testing_num = $t->current_test;
|
|
$t->current_test(0);
|
|
|
|
@@ -188,20 +185,18 @@
|
|
|
|
=cut
|
|
|
|
-sub test_out(@)
|
|
-{
|
|
+sub test_out {
|
|
# do we need to do any setup?
|
|
_start_testing() unless $testing;
|
|
|
|
- $out->expect(@_)
|
|
+ $out->expect(@_);
|
|
}
|
|
|
|
-sub test_err(@)
|
|
-{
|
|
+sub test_err {
|
|
# do we need to do any setup?
|
|
_start_testing() unless $testing;
|
|
|
|
- $err->expect(@_)
|
|
+ $err->expect(@_);
|
|
}
|
|
|
|
=item test_fail
|
|
@@ -230,14 +225,13 @@
|
|
|
|
=cut
|
|
|
|
-sub test_fail
|
|
-{
|
|
+sub test_fail {
|
|
# do we need to do any setup?
|
|
_start_testing() unless $testing;
|
|
|
|
# work out what line we should be on
|
|
- my ($package, $filename, $line) = caller;
|
|
- $line = $line + (shift() || 0); # prevent warnings
|
|
+ my( $package, $filename, $line ) = caller;
|
|
+ $line = $line + ( shift() || 0 ); # prevent warnings
|
|
|
|
# expect that on stderr
|
|
$err->expect("# Failed test ($0 at line $line)");
|
|
@@ -273,14 +267,13 @@
|
|
|
|
=cut
|
|
|
|
-sub test_diag
|
|
-{
|
|
+sub test_diag {
|
|
# do we need to do any setup?
|
|
_start_testing() unless $testing;
|
|
|
|
# expect the same thing, but prepended with "# "
|
|
local $_;
|
|
- $err->expect(map {"# $_"} @_)
|
|
+ $err->expect( map { "# $_" } @_ );
|
|
}
|
|
|
|
=item test_test
|
|
@@ -322,24 +315,23 @@
|
|
|
|
=cut
|
|
|
|
-sub test_test
|
|
-{
|
|
- # decode the arguements as described in the pod
|
|
- my $mess;
|
|
- my %args;
|
|
- if (@_ == 1)
|
|
- { $mess = shift }
|
|
- else
|
|
- {
|
|
- %args = @_;
|
|
- $mess = $args{name} if exists($args{name});
|
|
- $mess = $args{title} if exists($args{title});
|
|
- $mess = $args{label} if exists($args{label});
|
|
- }
|
|
+sub test_test {
|
|
+ # decode the arguements as described in the pod
|
|
+ my $mess;
|
|
+ my %args;
|
|
+ if( @_ == 1 ) {
|
|
+ $mess = shift
|
|
+ }
|
|
+ else {
|
|
+ %args = @_;
|
|
+ $mess = $args{name} if exists( $args{name} );
|
|
+ $mess = $args{title} if exists( $args{title} );
|
|
+ $mess = $args{label} if exists( $args{label} );
|
|
+ }
|
|
|
|
# er, are we testing?
|
|
croak "Not testing. You must declare output with a test function first."
|
|
- unless $testing;
|
|
+ unless $testing;
|
|
|
|
# okay, reconnect the test suite back to the saved handles
|
|
$t->output($original_output_handle);
|
|
@@ -354,20 +346,20 @@
|
|
$ENV{HARNESS_ACTIVE} = $original_harness_env;
|
|
|
|
# check the output we've stashed
|
|
- unless ($t->ok( ($args{skip_out} || $out->check)
|
|
- && ($args{skip_err} || $err->check),
|
|
- $mess))
|
|
+ unless( $t->ok( ( $args{skip_out} || $out->check ) &&
|
|
+ ( $args{skip_err} || $err->check ), $mess )
|
|
+ )
|
|
{
|
|
- # print out the diagnostic information about why this
|
|
- # test failed
|
|
+ # print out the diagnostic information about why this
|
|
+ # test failed
|
|
|
|
- local $_;
|
|
+ local $_;
|
|
|
|
- $t->diag(map {"$_\n"} $out->complaint)
|
|
- unless $args{skip_out} || $out->check;
|
|
+ $t->diag( map { "$_\n" } $out->complaint )
|
|
+ unless $args{skip_out} || $out->check;
|
|
|
|
- $t->diag(map {"$_\n"} $err->complaint)
|
|
- unless $args{skip_err} || $err->check;
|
|
+ $t->diag( map { "$_\n" } $err->complaint )
|
|
+ unless $args{skip_err} || $err->check;
|
|
}
|
|
}
|
|
|
|
@@ -383,10 +375,9 @@
|
|
|
|
=cut
|
|
|
|
-sub line_num
|
|
-{
|
|
- my ($package, $filename, $line) = caller;
|
|
- return $line + (shift() || 0); # prevent warnings
|
|
+sub line_num {
|
|
+ my( $package, $filename, $line ) = caller;
|
|
+ return $line + ( shift() || 0 ); # prevent warnings
|
|
}
|
|
|
|
=back
|
|
@@ -432,10 +423,10 @@
|
|
=cut
|
|
|
|
my $color;
|
|
-sub color
|
|
-{
|
|
- $color = shift if @_;
|
|
- $color;
|
|
+
|
|
+sub color {
|
|
+ $color = shift if @_;
|
|
+ $color;
|
|
}
|
|
|
|
=back
|
|
@@ -490,21 +481,18 @@
|
|
##
|
|
# add line(s) to be expected
|
|
|
|
-sub expect
|
|
-{
|
|
+sub expect {
|
|
my $self = shift;
|
|
|
|
my @checks = @_;
|
|
foreach my $check (@checks) {
|
|
$check = $self->_translate_Failed_check($check);
|
|
- push @{$self->{wanted}}, ref $check ? $check : "$check\n";
|
|
+ push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
|
|
}
|
|
}
|
|
|
|
-
|
|
-sub _translate_Failed_check
|
|
-{
|
|
- my($self, $check) = @_;
|
|
+sub _translate_Failed_check {
|
|
+ my( $self, $check ) = @_;
|
|
|
|
if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
|
|
$check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
|
|
@@ -513,21 +501,19 @@
|
|
return $check;
|
|
}
|
|
|
|
-
|
|
##
|
|
# return true iff the expected data matches the got data
|
|
|
|
-sub check
|
|
-{
|
|
+sub check {
|
|
my $self = shift;
|
|
|
|
# turn off warnings as these might be undef
|
|
local $^W = 0;
|
|
|
|
- my @checks = @{$self->{wanted}};
|
|
- my $got = $self->{got};
|
|
+ my @checks = @{ $self->{wanted} };
|
|
+ my $got = $self->{got};
|
|
foreach my $check (@checks) {
|
|
- $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check);
|
|
+ $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
|
|
return 0 unless $got =~ s/^$check//;
|
|
}
|
|
|
|
@@ -538,82 +524,71 @@
|
|
# a complaint message about the inputs not matching (to be
|
|
# used for debugging messages)
|
|
|
|
-sub complaint
|
|
-{
|
|
- my $self = shift;
|
|
+sub complaint {
|
|
+ my $self = shift;
|
|
my $type = $self->type;
|
|
my $got = $self->got;
|
|
- my $wanted = join "\n", @{$self->wanted};
|
|
+ my $wanted = join "\n", @{ $self->wanted };
|
|
|
|
# are we running in colour mode?
|
|
- if (Test::Builder::Tester::color)
|
|
- {
|
|
- # get color
|
|
- eval "require Term::ANSIColor";
|
|
- unless ($@)
|
|
- {
|
|
- # colours
|
|
-
|
|
- my $green = Term::ANSIColor::color("black").
|
|
- Term::ANSIColor::color("on_green");
|
|
- my $red = Term::ANSIColor::color("black").
|
|
- Term::ANSIColor::color("on_red");
|
|
- my $reset = Term::ANSIColor::color("reset");
|
|
-
|
|
- # work out where the two strings start to differ
|
|
- my $char = 0;
|
|
- $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
|
|
-
|
|
- # get the start string and the two end strings
|
|
- my $start = $green . substr($wanted, 0, $char);
|
|
- my $gotend = $red . substr($got , $char) . $reset;
|
|
- my $wantedend = $red . substr($wanted, $char) . $reset;
|
|
-
|
|
- # make the start turn green on and off
|
|
- $start =~ s/\n/$reset\n$green/g;
|
|
-
|
|
- # make the ends turn red on and off
|
|
- $gotend =~ s/\n/$reset\n$red/g;
|
|
- $wantedend =~ s/\n/$reset\n$red/g;
|
|
-
|
|
- # rebuild the strings
|
|
- $got = $start . $gotend;
|
|
- $wanted = $start . $wantedend;
|
|
- }
|
|
+ if(Test::Builder::Tester::color) {
|
|
+ # get color
|
|
+ eval { require Term::ANSIColor };
|
|
+ unless($@) {
|
|
+ # colours
|
|
+
|
|
+ my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
|
|
+ my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
|
|
+ my $reset = Term::ANSIColor::color("reset");
|
|
+
|
|
+ # work out where the two strings start to differ
|
|
+ my $char = 0;
|
|
+ $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
|
|
+
|
|
+ # get the start string and the two end strings
|
|
+ my $start = $green . substr( $wanted, 0, $char );
|
|
+ my $gotend = $red . substr( $got, $char ) . $reset;
|
|
+ my $wantedend = $red . substr( $wanted, $char ) . $reset;
|
|
+
|
|
+ # make the start turn green on and off
|
|
+ $start =~ s/\n/$reset\n$green/g;
|
|
+
|
|
+ # make the ends turn red on and off
|
|
+ $gotend =~ s/\n/$reset\n$red/g;
|
|
+ $wantedend =~ s/\n/$reset\n$red/g;
|
|
+
|
|
+ # rebuild the strings
|
|
+ $got = $start . $gotend;
|
|
+ $wanted = $start . $wantedend;
|
|
+ }
|
|
}
|
|
|
|
- return "$type is:\n" .
|
|
- "$got\nnot:\n$wanted\nas expected"
|
|
+ return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
|
|
}
|
|
|
|
##
|
|
# forget all expected and got data
|
|
|
|
-sub reset
|
|
-{
|
|
+sub reset {
|
|
my $self = shift;
|
|
%$self = (
|
|
- type => $self->{type},
|
|
- got => '',
|
|
- wanted => [],
|
|
- );
|
|
+ type => $self->{type},
|
|
+ got => '',
|
|
+ wanted => [],
|
|
+ );
|
|
}
|
|
|
|
-
|
|
-sub got
|
|
-{
|
|
+sub got {
|
|
my $self = shift;
|
|
return $self->{got};
|
|
}
|
|
|
|
-sub wanted
|
|
-{
|
|
+sub wanted {
|
|
my $self = shift;
|
|
return $self->{wanted};
|
|
}
|
|
|
|
-sub type
|
|
-{
|
|
+sub type {
|
|
my $self = shift;
|
|
return $self->{type};
|
|
}
|
|
@@ -622,26 +597,24 @@
|
|
# tie interface
|
|
###
|
|
|
|
-sub PRINT {
|
|
+sub PRINT {
|
|
my $self = shift;
|
|
$self->{got} .= join '', @_;
|
|
}
|
|
|
|
sub TIEHANDLE {
|
|
- my($class, $type) = @_;
|
|
+ my( $class, $type ) = @_;
|
|
|
|
- my $self = bless {
|
|
- type => $type
|
|
- }, $class;
|
|
+ my $self = bless { type => $type }, $class;
|
|
|
|
$self->reset;
|
|
|
|
return $self;
|
|
}
|
|
|
|
-sub READ {}
|
|
-sub READLINE {}
|
|
-sub GETC {}
|
|
-sub FILENO {}
|
|
+sub READ { }
|
|
+sub READLINE { }
|
|
+sub GETC { }
|
|
+sub FILENO { }
|
|
|
|
1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Builder.pm perl-5.10.0/lib/Test/Builder.pm
|
|
--- perl-5.10.0.orig/lib/Test/Builder.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Builder.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,25 +1,28 @@
|
|
package Test::Builder;
|
|
|
|
-use 5.004;
|
|
+use 5.006;
|
|
+use strict;
|
|
+use warnings;
|
|
|
|
-# $^C was only introduced in 5.005-ish. We do this to prevent
|
|
-# use of uninitialized value warnings in older perls.
|
|
-$^C ||= 0;
|
|
+our $VERSION = '0.92';
|
|
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
+
|
|
+BEGIN {
|
|
+ if( $] < 5.008 ) {
|
|
+ require Test::Builder::IO::Scalar;
|
|
+ }
|
|
+}
|
|
|
|
-use strict;
|
|
-use vars qw($VERSION);
|
|
-$VERSION = '0.72';
|
|
-$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.
|
|
# 5.8.0's threads are so busted we no longer support them.
|
|
- if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
|
|
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
|
|
require threads::shared;
|
|
|
|
- # Hack around YET ANOTHER threads::shared bug. It would
|
|
+ # Hack around YET ANOTHER threads::shared bug. It would
|
|
# occassionally forget the contents of the variable when sharing it.
|
|
# So we first copy the data, then share, then put our copy back.
|
|
*share = sub (\[$@%]) {
|
|
@@ -27,31 +30,31 @@
|
|
my $data;
|
|
|
|
if( $type eq 'HASH' ) {
|
|
- %$data = %{$_[0]};
|
|
+ %$data = %{ $_[0] };
|
|
}
|
|
elsif( $type eq 'ARRAY' ) {
|
|
- @$data = @{$_[0]};
|
|
+ @$data = @{ $_[0] };
|
|
}
|
|
elsif( $type eq 'SCALAR' ) {
|
|
- $$data = ${$_[0]};
|
|
+ $$data = ${ $_[0] };
|
|
}
|
|
else {
|
|
- die("Unknown type: ".$type);
|
|
+ die( "Unknown type: " . $type );
|
|
}
|
|
|
|
- $_[0] = &threads::shared::share($_[0]);
|
|
+ $_[0] = &threads::shared::share( $_[0] );
|
|
|
|
if( $type eq 'HASH' ) {
|
|
- %{$_[0]} = %$data;
|
|
+ %{ $_[0] } = %$data;
|
|
}
|
|
elsif( $type eq 'ARRAY' ) {
|
|
- @{$_[0]} = @$data;
|
|
+ @{ $_[0] } = @$data;
|
|
}
|
|
elsif( $type eq 'SCALAR' ) {
|
|
- ${$_[0]} = $$data;
|
|
+ ${ $_[0] } = $$data;
|
|
}
|
|
else {
|
|
- die("Unknown type: ".$type);
|
|
+ die( "Unknown type: " . $type );
|
|
}
|
|
|
|
return $_[0];
|
|
@@ -65,7 +68,6 @@
|
|
}
|
|
}
|
|
|
|
-
|
|
=head1 NAME
|
|
|
|
Test::Builder - Backend for building test libraries
|
|
@@ -73,28 +75,15 @@
|
|
=head1 SYNOPSIS
|
|
|
|
package My::Test::Module;
|
|
- use Test::Builder;
|
|
- require Exporter;
|
|
- @ISA = qw(Exporter);
|
|
- @EXPORT = qw(ok);
|
|
+ use base 'Test::Builder::Module';
|
|
|
|
- my $Test = Test::Builder->new;
|
|
- $Test->output('my_logfile');
|
|
-
|
|
- sub import {
|
|
- my($self) = shift;
|
|
- my $pack = caller;
|
|
-
|
|
- $Test->exported_to($pack);
|
|
- $Test->plan(@_);
|
|
-
|
|
- $self->export_to_level(1, $self, 'ok');
|
|
- }
|
|
+ my $CLASS = __PACKAGE__;
|
|
|
|
sub ok {
|
|
my($test, $name) = @_;
|
|
+ my $tb = $CLASS->builder;
|
|
|
|
- $Test->ok($test, $name);
|
|
+ $tb->ok($test, $name);
|
|
}
|
|
|
|
|
|
@@ -117,7 +106,7 @@
|
|
test.
|
|
|
|
Since you only run one test per program C<new> always returns the same
|
|
-Test::Builder object. No matter how many times you call new(), you're
|
|
+Test::Builder object. No matter how many times you call C<new()>, you're
|
|
getting the same object. This is called a singleton. This is done so that
|
|
multiple modules share such global information as the test counter and
|
|
where test output is going.
|
|
@@ -128,13 +117,13 @@
|
|
=cut
|
|
|
|
my $Test = Test::Builder->new;
|
|
+
|
|
sub new {
|
|
my($class) = shift;
|
|
$Test ||= $class->create;
|
|
return $Test;
|
|
}
|
|
|
|
-
|
|
=item B<create>
|
|
|
|
my $Test = Test::Builder->create;
|
|
@@ -168,37 +157,43 @@
|
|
|
|
=cut
|
|
|
|
-use vars qw($Level);
|
|
+our $Level;
|
|
|
|
-sub reset {
|
|
- my ($self) = @_;
|
|
+sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
|
|
+ my($self) = @_;
|
|
|
|
# We leave this a global because it has to be localized and localizing
|
|
# hash keys is just asking for pain. Also, it was documented.
|
|
$Level = 1;
|
|
|
|
- $self->{Test_Died} = 0;
|
|
$self->{Have_Plan} = 0;
|
|
$self->{No_Plan} = 0;
|
|
+ $self->{Have_Output_Plan} = 0;
|
|
+
|
|
$self->{Original_Pid} = $$;
|
|
|
|
- share($self->{Curr_Test});
|
|
- $self->{Curr_Test} = 0;
|
|
- $self->{Test_Results} = &share([]);
|
|
+ share( $self->{Curr_Test} );
|
|
+ $self->{Curr_Test} = 0;
|
|
+ $self->{Test_Results} = &share( [] );
|
|
|
|
$self->{Exported_To} = undef;
|
|
$self->{Expected_Tests} = 0;
|
|
|
|
- $self->{Skip_All} = 0;
|
|
+ $self->{Skip_All} = 0;
|
|
+
|
|
+ $self->{Use_Nums} = 1;
|
|
|
|
- $self->{Use_Nums} = 1;
|
|
+ $self->{No_Header} = 0;
|
|
+ $self->{No_Ending} = 0;
|
|
|
|
- $self->{No_Header} = 0;
|
|
- $self->{No_Ending} = 0;
|
|
+ $self->{Todo} = undef;
|
|
+ $self->{Todo_Stack} = [];
|
|
+ $self->{Start_Todo} = 0;
|
|
+ $self->{Opened_Testhandles} = 0;
|
|
|
|
- $self->_dup_stdhandles unless $^C;
|
|
+ $self->_dup_stdhandles;
|
|
|
|
- return undef;
|
|
+ return;
|
|
}
|
|
|
|
=back
|
|
@@ -210,25 +205,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');
|
|
@@ -238,53 +214,62 @@
|
|
A convenient way to set up your tests. Call this and Test::Builder
|
|
will print the appropriate headers and take the appropriate actions.
|
|
|
|
-If you call plan(), don't call any of the other methods below.
|
|
+If you call C<plan()>, don't call any of the other methods below.
|
|
|
|
=cut
|
|
|
|
+my %plan_cmds = (
|
|
+ no_plan => \&no_plan,
|
|
+ skip_all => \&skip_all,
|
|
+ tests => \&_plan_tests,
|
|
+);
|
|
+
|
|
sub plan {
|
|
- my($self, $cmd, $arg) = @_;
|
|
+ my( $self, $cmd, $arg ) = @_;
|
|
|
|
return unless $cmd;
|
|
|
|
local $Level = $Level + 1;
|
|
|
|
- if( $self->{Have_Plan} ) {
|
|
- $self->croak("You tried to plan twice");
|
|
- }
|
|
+ $self->croak("You tried to plan twice") if $self->{Have_Plan};
|
|
|
|
- if( $cmd eq 'no_plan' ) {
|
|
- $self->no_plan;
|
|
- }
|
|
- elsif( $cmd eq 'skip_all' ) {
|
|
- return $self->skip_all($arg);
|
|
- }
|
|
- elsif( $cmd eq 'tests' ) {
|
|
- if( $arg ) {
|
|
- local $Level = $Level + 1;
|
|
- return $self->expected_tests($arg);
|
|
- }
|
|
- elsif( !defined $arg ) {
|
|
- $self->croak("Got an undefined number of tests");
|
|
- }
|
|
- elsif( !$arg ) {
|
|
- $self->croak("You said to run 0 tests");
|
|
- }
|
|
+ if( my $method = $plan_cmds{$cmd} ) {
|
|
+ local $Level = $Level + 1;
|
|
+ $self->$method($arg);
|
|
}
|
|
else {
|
|
- my @args = grep { defined } ($cmd, $arg);
|
|
+ my @args = grep { defined } ( $cmd, $arg );
|
|
$self->croak("plan() doesn't understand @args");
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
+
|
|
+sub _plan_tests {
|
|
+ my($self, $arg) = @_;
|
|
+
|
|
+ if($arg) {
|
|
+ local $Level = $Level + 1;
|
|
+ return $self->expected_tests($arg);
|
|
+ }
|
|
+ elsif( !defined $arg ) {
|
|
+ $self->croak("Got an undefined number of tests");
|
|
+ }
|
|
+ else {
|
|
+ $self->croak("You said to run 0 tests");
|
|
+ }
|
|
+
|
|
+ return;
|
|
+}
|
|
+
|
|
+
|
|
=item B<expected_tests>
|
|
|
|
my $max = $Test->expected_tests;
|
|
$Test->expected_tests($max);
|
|
|
|
-Gets/sets the # of tests we expect this test to run and prints out
|
|
+Gets/sets the number of tests we expect this test to run and prints out
|
|
the appropriate headers.
|
|
|
|
=cut
|
|
@@ -293,73 +278,204 @@
|
|
my $self = shift;
|
|
my($max) = @_;
|
|
|
|
- if( @_ ) {
|
|
+ if(@_) {
|
|
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
|
|
- unless $max =~ /^\+?\d+$/ and $max > 0;
|
|
+ unless $max =~ /^\+?\d+$/;
|
|
|
|
$self->{Expected_Tests} = $max;
|
|
$self->{Have_Plan} = 1;
|
|
|
|
- $self->_print("1..$max\n") unless $self->no_header;
|
|
+ $self->_output_plan($max) unless $self->no_header;
|
|
}
|
|
return $self->{Expected_Tests};
|
|
}
|
|
|
|
-
|
|
=item B<no_plan>
|
|
|
|
$Test->no_plan;
|
|
|
|
-Declares that this test will run an indeterminate # of tests.
|
|
+Declares that this test will run an indeterminate number of tests.
|
|
|
|
=cut
|
|
|
|
sub no_plan {
|
|
- my $self = shift;
|
|
+ my($self, $arg) = @_;
|
|
+
|
|
+ $self->carp("no_plan takes no arguments") if $arg;
|
|
|
|
$self->{No_Plan} = 1;
|
|
$self->{Have_Plan} = 1;
|
|
+
|
|
+ return 1;
|
|
}
|
|
|
|
+
|
|
+=begin private
|
|
+
|
|
+=item B<_output_plan>
|
|
+
|
|
+ $tb->_output_plan($max);
|
|
+ $tb->_output_plan($max, $directive);
|
|
+ $tb->_output_plan($max, $directive => $reason);
|
|
+
|
|
+Handles displaying the test plan.
|
|
+
|
|
+If a C<$directive> and/or C<$reason> are given they will be output with the
|
|
+plan. So here's what skipping all tests looks like:
|
|
+
|
|
+ $tb->_output_plan(0, "SKIP", "Because I said so");
|
|
+
|
|
+It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
|
|
+output.
|
|
+
|
|
+=end private
|
|
+
|
|
+=cut
|
|
+
|
|
+sub _output_plan {
|
|
+ my($self, $max, $directive, $reason) = @_;
|
|
+
|
|
+ $self->carp("The plan was already output") if $self->{Have_Output_Plan};
|
|
+
|
|
+ my $plan = "1..$max";
|
|
+ $plan .= " # $directive" if defined $directive;
|
|
+ $plan .= " $reason" if defined $reason;
|
|
+
|
|
+ $self->_print("$plan\n");
|
|
+
|
|
+ $self->{Have_Output_Plan} = 1;
|
|
+
|
|
+ return;
|
|
+}
|
|
+
|
|
+=item B<done_testing>
|
|
+
|
|
+ $Test->done_testing();
|
|
+ $Test->done_testing($num_tests);
|
|
+
|
|
+Declares that you are done testing, no more tests will be run after this point.
|
|
+
|
|
+If a plan has not yet been output, it will do so.
|
|
+
|
|
+$num_tests is the number of tests you planned to run. If a numbered
|
|
+plan was already declared, and if this contradicts, a failing test
|
|
+will be run to reflect the planning mistake. If C<no_plan> was declared,
|
|
+this will override.
|
|
+
|
|
+If C<done_testing()> is called twice, the second call will issue a
|
|
+failing test.
|
|
+
|
|
+If C<$num_tests> is omitted, the number of tests run will be used, like
|
|
+no_plan.
|
|
+
|
|
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
|
|
+safer. You'd use it like so:
|
|
+
|
|
+ $Test->ok($a == $b);
|
|
+ $Test->done_testing();
|
|
+
|
|
+Or to plan a variable number of tests:
|
|
+
|
|
+ for my $test (@tests) {
|
|
+ $Test->ok($test);
|
|
+ }
|
|
+ $Test->done_testing(@tests);
|
|
+
|
|
+=cut
|
|
+
|
|
+sub done_testing {
|
|
+ my($self, $num_tests) = @_;
|
|
+
|
|
+ # If done_testing() specified the number of tests, shut off no_plan.
|
|
+ if( defined $num_tests ) {
|
|
+ $self->{No_Plan} = 0;
|
|
+ }
|
|
+ else {
|
|
+ $num_tests = $self->current_test;
|
|
+ }
|
|
+
|
|
+ if( $self->{Done_Testing} ) {
|
|
+ my($file, $line) = @{$self->{Done_Testing}}[1,2];
|
|
+ $self->ok(0, "done_testing() was already called at $file line $line");
|
|
+ return;
|
|
+ }
|
|
+
|
|
+ $self->{Done_Testing} = [caller];
|
|
+
|
|
+ if( $self->expected_tests && $num_tests != $self->expected_tests ) {
|
|
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
|
|
+ "but done_testing() expects $num_tests");
|
|
+ }
|
|
+ else {
|
|
+ $self->{Expected_Tests} = $num_tests;
|
|
+ }
|
|
+
|
|
+ $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
|
|
+
|
|
+ $self->{Have_Plan} = 1;
|
|
+
|
|
+ return 1;
|
|
+}
|
|
+
|
|
+
|
|
=item B<has_plan>
|
|
|
|
$plan = $Test->has_plan
|
|
|
|
-Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
|
|
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
|
|
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
|
|
+of expected tests).
|
|
|
|
=cut
|
|
|
|
sub has_plan {
|
|
my $self = shift;
|
|
|
|
- return($self->{Expected_Tests}) if $self->{Expected_Tests};
|
|
+ return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
|
|
return('no_plan') if $self->{No_Plan};
|
|
return(undef);
|
|
-};
|
|
-
|
|
+}
|
|
|
|
=item B<skip_all>
|
|
|
|
$Test->skip_all;
|
|
$Test->skip_all($reason);
|
|
|
|
-Skips all the tests, using the given $reason. Exits immediately with 0.
|
|
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
|
|
|
|
=cut
|
|
|
|
sub skip_all {
|
|
- my($self, $reason) = @_;
|
|
-
|
|
- my $out = "1..0";
|
|
- $out .= " # Skip $reason" if $reason;
|
|
- $out .= "\n";
|
|
+ my( $self, $reason ) = @_;
|
|
|
|
$self->{Skip_All} = 1;
|
|
|
|
- $self->_print($out) unless $self->no_header;
|
|
+ $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
|
|
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
|
|
@@ -368,7 +484,7 @@
|
|
|
|
They all return true if the test passed, false if the test failed.
|
|
|
|
-$name is always optional.
|
|
+C<$name> is always optional.
|
|
|
|
=over 4
|
|
|
|
@@ -376,42 +492,43 @@
|
|
|
|
$Test->ok($test, $name);
|
|
|
|
-Your basic test. Pass if $test is true, fail if $test is false. Just
|
|
-like Test::Simple's ok().
|
|
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
|
|
+like Test::Simple's C<ok()>.
|
|
|
|
=cut
|
|
|
|
sub ok {
|
|
- my($self, $test, $name) = @_;
|
|
+ my( $self, $test, $name ) = @_;
|
|
|
|
# $test might contain an object which we don't want to accidentally
|
|
# store, so we turn it into a boolean.
|
|
$test = $test ? 1 : 0;
|
|
|
|
- $self->_plan_check;
|
|
-
|
|
lock $self->{Curr_Test};
|
|
$self->{Curr_Test}++;
|
|
|
|
# In case $name is a string overloaded object, force it to stringify.
|
|
- $self->_unoverload_str(\$name);
|
|
+ $self->_unoverload_str( \$name );
|
|
|
|
- $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
|
|
+ $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
|
|
You named your test '$name'. You shouldn't use numbers for your test names.
|
|
Very confusing.
|
|
ERR
|
|
|
|
- my($pack, $file, $line) = $self->caller;
|
|
+ # Capture the value of $TODO for the rest of this ok() call
|
|
+ # so it can more easily be found by other routines.
|
|
+ my $todo = $self->todo();
|
|
+ my $in_todo = $self->in_todo;
|
|
+ local $self->{Todo} = $todo if $in_todo;
|
|
|
|
- my $todo = $self->todo($pack);
|
|
- $self->_unoverload_str(\$todo);
|
|
+ $self->_unoverload_str( \$todo );
|
|
|
|
my $out;
|
|
- my $result = &share({});
|
|
+ my $result = &share( {} );
|
|
|
|
- unless( $test ) {
|
|
+ unless($test) {
|
|
$out .= "not ";
|
|
- @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
|
|
+ @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
|
|
}
|
|
else {
|
|
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
|
|
@@ -421,16 +538,16 @@
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers;
|
|
|
|
if( defined $name ) {
|
|
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
|
|
- $out .= " - $name";
|
|
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
|
|
+ $out .= " - $name";
|
|
$result->{name} = $name;
|
|
}
|
|
else {
|
|
$result->{name} = '';
|
|
}
|
|
|
|
- if( $todo ) {
|
|
- $out .= " # TODO $todo";
|
|
+ if( $self->in_todo ) {
|
|
+ $out .= " # TODO $todo";
|
|
$result->{reason} = $todo;
|
|
$result->{type} = 'todo';
|
|
}
|
|
@@ -439,309 +556,341 @@
|
|
$result->{type} = '';
|
|
}
|
|
|
|
- $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
|
|
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
|
|
$out .= "\n";
|
|
|
|
$self->_print($out);
|
|
|
|
- unless( $test ) {
|
|
- my $msg = $todo ? "Failed (TODO)" : "Failed";
|
|
- $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
|
|
-
|
|
- 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]);
|
|
- }
|
|
- }
|
|
+ unless($test) {
|
|
+ my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
|
|
+ $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
|
|
+
|
|
+ my( undef, $file, $line ) = $self->caller;
|
|
+ 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;
|
|
}
|
|
|
|
-
|
|
sub _unoverload {
|
|
- my $self = shift;
|
|
- my $type = shift;
|
|
+ my $self = shift;
|
|
+ my $type = shift;
|
|
|
|
- $self->_try(sub { require overload } ) || return;
|
|
+ $self->_try(sub { require overload; }, die_on_fail => 1);
|
|
|
|
foreach my $thing (@_) {
|
|
if( $self->_is_object($$thing) ) {
|
|
- if( my $string_meth = overload::Method($$thing, $type) ) {
|
|
+ if( my $string_meth = overload::Method( $$thing, $type ) ) {
|
|
$$thing = $$thing->$string_meth();
|
|
}
|
|
}
|
|
}
|
|
-}
|
|
|
|
+ return;
|
|
+}
|
|
|
|
sub _is_object {
|
|
- my($self, $thing) = @_;
|
|
+ my( $self, $thing ) = @_;
|
|
|
|
- return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
|
|
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
|
|
}
|
|
|
|
-
|
|
sub _unoverload_str {
|
|
my $self = shift;
|
|
|
|
- $self->_unoverload(q[""], @_);
|
|
-}
|
|
+ return $self->_unoverload( q[""], @_ );
|
|
+}
|
|
|
|
sub _unoverload_num {
|
|
my $self = shift;
|
|
|
|
- $self->_unoverload('0+', @_);
|
|
+ $self->_unoverload( '0+', @_ );
|
|
|
|
for my $val (@_) {
|
|
next unless $self->_is_dualvar($$val);
|
|
- $$val = $$val+0;
|
|
+ $$val = $$val + 0;
|
|
}
|
|
-}
|
|
|
|
+ return;
|
|
+}
|
|
|
|
# This is a hack to detect a dualvar such as $!
|
|
sub _is_dualvar {
|
|
- my($self, $val) = @_;
|
|
-
|
|
- local $^W = 0;
|
|
- my $numval = $val+0;
|
|
- return 1 if $numval != 0 and $numval ne $val;
|
|
-}
|
|
+ my( $self, $val ) = @_;
|
|
|
|
+ # Objects are not dualvars.
|
|
+ return 0 if ref $val;
|
|
|
|
+ no warnings 'numeric';
|
|
+ my $numval = $val + 0;
|
|
+ return $numval != 0 and $numval ne $val ? 1 : 0;
|
|
+}
|
|
|
|
=item B<is_eq>
|
|
|
|
$Test->is_eq($got, $expected, $name);
|
|
|
|
-Like Test::More's is(). Checks if $got eq $expected. This is the
|
|
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
|
|
string version.
|
|
|
|
=item B<is_num>
|
|
|
|
$Test->is_num($got, $expected, $name);
|
|
|
|
-Like Test::More's is(). Checks if $got == $expected. This is the
|
|
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
|
|
numeric version.
|
|
|
|
=cut
|
|
|
|
sub is_eq {
|
|
- my($self, $got, $expect, $name) = @_;
|
|
+ my( $self, $got, $expect, $name ) = @_;
|
|
local $Level = $Level + 1;
|
|
|
|
- $self->_unoverload_str(\$got, \$expect);
|
|
+ $self->_unoverload_str( \$got, \$expect );
|
|
|
|
if( !defined $got || !defined $expect ) {
|
|
# undef only matches undef and nothing else
|
|
my $test = !defined $got && !defined $expect;
|
|
|
|
- $self->ok($test, $name);
|
|
- $self->_is_diag($got, 'eq', $expect) unless $test;
|
|
+ $self->ok( $test, $name );
|
|
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
|
|
return $test;
|
|
}
|
|
|
|
- return $self->cmp_ok($got, 'eq', $expect, $name);
|
|
+ return $self->cmp_ok( $got, 'eq', $expect, $name );
|
|
}
|
|
|
|
sub is_num {
|
|
- my($self, $got, $expect, $name) = @_;
|
|
+ my( $self, $got, $expect, $name ) = @_;
|
|
local $Level = $Level + 1;
|
|
|
|
- $self->_unoverload_num(\$got, \$expect);
|
|
+ $self->_unoverload_num( \$got, \$expect );
|
|
|
|
if( !defined $got || !defined $expect ) {
|
|
# undef only matches undef and nothing else
|
|
my $test = !defined $got && !defined $expect;
|
|
|
|
- $self->ok($test, $name);
|
|
- $self->_is_diag($got, '==', $expect) unless $test;
|
|
+ $self->ok( $test, $name );
|
|
+ $self->_is_diag( $got, '==', $expect ) unless $test;
|
|
return $test;
|
|
}
|
|
|
|
- return $self->cmp_ok($got, '==', $expect, $name);
|
|
+ return $self->cmp_ok( $got, '==', $expect, $name );
|
|
}
|
|
|
|
-sub _is_diag {
|
|
- my($self, $got, $type, $expect) = @_;
|
|
+sub _diag_fmt {
|
|
+ my( $self, $type, $val ) = @_;
|
|
|
|
- foreach my $val (\$got, \$expect) {
|
|
- if( defined $$val ) {
|
|
- if( $type eq 'eq' ) {
|
|
- # quote and force string context
|
|
- $$val = "'$$val'"
|
|
- }
|
|
- else {
|
|
- # force numeric context
|
|
- $self->_unoverload_num($val);
|
|
- }
|
|
+ if( defined $$val ) {
|
|
+ if( $type eq 'eq' or $type eq 'ne' ) {
|
|
+ # quote and force string context
|
|
+ $$val = "'$$val'";
|
|
}
|
|
else {
|
|
- $$val = 'undef';
|
|
+ # force numeric context
|
|
+ $self->_unoverload_num($val);
|
|
}
|
|
}
|
|
+ else {
|
|
+ $$val = 'undef';
|
|
+ }
|
|
+
|
|
+ return;
|
|
+}
|
|
+
|
|
+sub _is_diag {
|
|
+ my( $self, $got, $type, $expect ) = @_;
|
|
+
|
|
+ $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
|
|
|
|
- return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
|
|
- got: %s
|
|
- expected: %s
|
|
+ local $Level = $Level + 1;
|
|
+ return $self->diag(<<"DIAGNOSTIC");
|
|
+ got: $got
|
|
+ expected: $expect
|
|
DIAGNOSTIC
|
|
|
|
-}
|
|
+}
|
|
+
|
|
+sub _isnt_diag {
|
|
+ my( $self, $got, $type ) = @_;
|
|
+
|
|
+ $self->_diag_fmt( $type, \$got );
|
|
+
|
|
+ local $Level = $Level + 1;
|
|
+ return $self->diag(<<"DIAGNOSTIC");
|
|
+ got: $got
|
|
+ expected: anything else
|
|
+DIAGNOSTIC
|
|
+}
|
|
|
|
=item B<isnt_eq>
|
|
|
|
$Test->isnt_eq($got, $dont_expect, $name);
|
|
|
|
-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
|
|
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
|
|
the string version.
|
|
|
|
=item B<isnt_num>
|
|
|
|
$Test->isnt_num($got, $dont_expect, $name);
|
|
|
|
-Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
|
|
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
|
|
the numeric version.
|
|
|
|
=cut
|
|
|
|
sub isnt_eq {
|
|
- my($self, $got, $dont_expect, $name) = @_;
|
|
+ my( $self, $got, $dont_expect, $name ) = @_;
|
|
local $Level = $Level + 1;
|
|
|
|
if( !defined $got || !defined $dont_expect ) {
|
|
# undef only matches undef and nothing else
|
|
my $test = defined $got || defined $dont_expect;
|
|
|
|
- $self->ok($test, $name);
|
|
- $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
|
|
+ $self->ok( $test, $name );
|
|
+ $self->_isnt_diag( $got, 'ne' ) unless $test;
|
|
return $test;
|
|
}
|
|
|
|
- return $self->cmp_ok($got, 'ne', $dont_expect, $name);
|
|
+ return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
|
|
}
|
|
|
|
sub isnt_num {
|
|
- my($self, $got, $dont_expect, $name) = @_;
|
|
+ my( $self, $got, $dont_expect, $name ) = @_;
|
|
local $Level = $Level + 1;
|
|
|
|
if( !defined $got || !defined $dont_expect ) {
|
|
# undef only matches undef and nothing else
|
|
my $test = defined $got || defined $dont_expect;
|
|
|
|
- $self->ok($test, $name);
|
|
- $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
|
|
+ $self->ok( $test, $name );
|
|
+ $self->_isnt_diag( $got, '!=' ) unless $test;
|
|
return $test;
|
|
}
|
|
|
|
- return $self->cmp_ok($got, '!=', $dont_expect, $name);
|
|
+ return $self->cmp_ok( $got, '!=', $dont_expect, $name );
|
|
}
|
|
|
|
-
|
|
=item B<like>
|
|
|
|
$Test->like($this, qr/$regex/, $name);
|
|
$Test->like($this, '/$regex/', $name);
|
|
|
|
-Like Test::More's like(). Checks if $this matches the given $regex.
|
|
+Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
|
|
|
|
-You'll want to avoid qr// if you want your tests to work before 5.005.
|
|
+You'll want to avoid C<qr//> if you want your tests to work before 5.005.
|
|
|
|
=item B<unlike>
|
|
|
|
$Test->unlike($this, qr/$regex/, $name);
|
|
$Test->unlike($this, '/$regex/', $name);
|
|
|
|
-Like Test::More's unlike(). Checks if $this B<does not match> the
|
|
-given $regex.
|
|
+Like Test::More's C<unlike()>. Checks if $this B<does not match> the
|
|
+given C<$regex>.
|
|
|
|
=cut
|
|
|
|
sub like {
|
|
- my($self, $this, $regex, $name) = @_;
|
|
+ my( $self, $this, $regex, $name ) = @_;
|
|
|
|
local $Level = $Level + 1;
|
|
- $self->_regex_ok($this, $regex, '=~', $name);
|
|
+ return $self->_regex_ok( $this, $regex, '=~', $name );
|
|
}
|
|
|
|
sub unlike {
|
|
- my($self, $this, $regex, $name) = @_;
|
|
+ my( $self, $this, $regex, $name ) = @_;
|
|
|
|
local $Level = $Level + 1;
|
|
- $self->_regex_ok($this, $regex, '!~', $name);
|
|
+ return $self->_regex_ok( $this, $regex, '!~', $name );
|
|
}
|
|
|
|
-
|
|
=item B<cmp_ok>
|
|
|
|
$Test->cmp_ok($this, $type, $that, $name);
|
|
|
|
-Works just like Test::More's cmp_ok().
|
|
+Works just like Test::More's C<cmp_ok()>.
|
|
|
|
$Test->cmp_ok($big_num, '!=', $other_big_num);
|
|
|
|
=cut
|
|
|
|
-
|
|
-my %numeric_cmps = map { ($_, 1) }
|
|
- ("<", "<=", ">", ">=", "==", "!=", "<=>");
|
|
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
|
|
|
|
sub cmp_ok {
|
|
- my($self, $got, $type, $expect, $name) = @_;
|
|
-
|
|
- # Treat overloaded objects as numbers if we're asked to do a
|
|
- # numeric comparison.
|
|
- my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
|
|
- : '_unoverload_str';
|
|
-
|
|
- $self->$unoverload(\$got, \$expect);
|
|
-
|
|
+ my( $self, $got, $type, $expect, $name ) = @_;
|
|
|
|
my $test;
|
|
+ my $error;
|
|
{
|
|
- local($@,$!,$SIG{__DIE__}); # isolate eval
|
|
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
|
|
- 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" . "\$got $type \$expect;";
|
|
+ my($pack, $file, $line) = $self->caller();
|
|
|
|
+ $test = eval qq[
|
|
+#line 1 "cmp_ok [from $file line $line]"
|
|
+\$got $type \$expect;
|
|
+];
|
|
+ $error = $@;
|
|
}
|
|
local $Level = $Level + 1;
|
|
- my $ok = $self->ok($test, $name);
|
|
+ my $ok = $self->ok( $test, $name );
|
|
+
|
|
+ # Treat overloaded objects as numbers if we're asked to do a
|
|
+ # numeric comparison.
|
|
+ my $unoverload
|
|
+ = $numeric_cmps{$type}
|
|
+ ? '_unoverload_num'
|
|
+ : '_unoverload_str';
|
|
+
|
|
+ $self->diag(<<"END") if $error;
|
|
+An error occurred while using $type:
|
|
+------------------------------------
|
|
+$error
|
|
+------------------------------------
|
|
+END
|
|
+
|
|
+ unless($ok) {
|
|
+ $self->$unoverload( \$got, \$expect );
|
|
|
|
- unless( $ok ) {
|
|
if( $type =~ /^(eq|==)$/ ) {
|
|
- $self->_is_diag($got, $type, $expect);
|
|
+ $self->_is_diag( $got, $type, $expect );
|
|
+ }
|
|
+ elsif( $type =~ /^(ne|!=)$/ ) {
|
|
+ $self->_isnt_diag( $got, $type );
|
|
}
|
|
else {
|
|
- $self->_cmp_diag($got, $type, $expect);
|
|
+ $self->_cmp_diag( $got, $type, $expect );
|
|
}
|
|
}
|
|
return $ok;
|
|
}
|
|
|
|
sub _cmp_diag {
|
|
- my($self, $got, $type, $expect) = @_;
|
|
-
|
|
+ my( $self, $got, $type, $expect ) = @_;
|
|
+
|
|
$got = defined $got ? "'$got'" : 'undef';
|
|
$expect = defined $expect ? "'$expect'" : 'undef';
|
|
- return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
|
|
- %s
|
|
- %s
|
|
- %s
|
|
+
|
|
+ local $Level = $Level + 1;
|
|
+ return $self->diag(<<"DIAGNOSTIC");
|
|
+ $got
|
|
+ $type
|
|
+ $expect
|
|
DIAGNOSTIC
|
|
}
|
|
|
|
-
|
|
sub _caller_context {
|
|
my $self = shift;
|
|
|
|
- my($pack, $file, $line) = $self->caller(1);
|
|
+ my( $pack, $file, $line ) = $self->caller(1);
|
|
|
|
my $code = '';
|
|
$code .= "#line $line $file\n" if defined $file and defined $line;
|
|
@@ -771,7 +920,7 @@
|
|
=cut
|
|
|
|
sub BAIL_OUT {
|
|
- my($self, $reason) = @_;
|
|
+ my( $self, $reason ) = @_;
|
|
|
|
$self->{Bailed_Out} = 1;
|
|
$self->_print("Bail out! $reason");
|
|
@@ -785,52 +934,50 @@
|
|
|
|
*BAILOUT = \&BAIL_OUT;
|
|
|
|
-
|
|
=item B<skip>
|
|
|
|
$Test->skip;
|
|
$Test->skip($why);
|
|
|
|
-Skips the current test, reporting $why.
|
|
+Skips the current test, reporting C<$why>.
|
|
|
|
=cut
|
|
|
|
sub skip {
|
|
- my($self, $why) = @_;
|
|
+ my( $self, $why ) = @_;
|
|
$why ||= '';
|
|
- $self->_unoverload_str(\$why);
|
|
-
|
|
- $self->_plan_check;
|
|
+ $self->_unoverload_str( \$why );
|
|
|
|
- lock($self->{Curr_Test});
|
|
+ lock( $self->{Curr_Test} );
|
|
$self->{Curr_Test}++;
|
|
|
|
- $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
|
|
- 'ok' => 1,
|
|
- actual_ok => 1,
|
|
- name => '',
|
|
- type => 'skip',
|
|
- reason => $why,
|
|
- });
|
|
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
|
|
+ {
|
|
+ 'ok' => 1,
|
|
+ actual_ok => 1,
|
|
+ name => '',
|
|
+ type => 'skip',
|
|
+ reason => $why,
|
|
+ }
|
|
+ );
|
|
|
|
my $out = "ok";
|
|
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
|
|
- $out .= " # skip";
|
|
- $out .= " $why" if length $why;
|
|
- $out .= "\n";
|
|
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
|
|
+ $out .= " # skip";
|
|
+ $out .= " $why" if length $why;
|
|
+ $out .= "\n";
|
|
|
|
$self->_print($out);
|
|
|
|
return 1;
|
|
}
|
|
|
|
-
|
|
=item B<todo_skip>
|
|
|
|
$Test->todo_skip;
|
|
$Test->todo_skip($why);
|
|
|
|
-Like skip(), only it will declare the test as failing and TODO. Similar
|
|
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
|
|
to
|
|
|
|
print "not ok $tnum # TODO $why\n";
|
|
@@ -838,32 +985,31 @@
|
|
=cut
|
|
|
|
sub todo_skip {
|
|
- my($self, $why) = @_;
|
|
+ my( $self, $why ) = @_;
|
|
$why ||= '';
|
|
|
|
- $self->_plan_check;
|
|
-
|
|
- lock($self->{Curr_Test});
|
|
+ lock( $self->{Curr_Test} );
|
|
$self->{Curr_Test}++;
|
|
|
|
- $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
|
|
- 'ok' => 1,
|
|
- actual_ok => 0,
|
|
- name => '',
|
|
- type => 'todo_skip',
|
|
- reason => $why,
|
|
- });
|
|
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
|
|
+ {
|
|
+ 'ok' => 1,
|
|
+ actual_ok => 0,
|
|
+ name => '',
|
|
+ type => 'todo_skip',
|
|
+ reason => $why,
|
|
+ }
|
|
+ );
|
|
|
|
my $out = "not ok";
|
|
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
|
|
- $out .= " # TODO & SKIP $why\n";
|
|
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
|
|
+ $out .= " # TODO & SKIP $why\n";
|
|
|
|
$self->_print($out);
|
|
|
|
return 1;
|
|
}
|
|
|
|
-
|
|
=begin _unimplemented
|
|
|
|
=item B<skip_rest>
|
|
@@ -871,10 +1017,10 @@
|
|
$Test->skip_rest;
|
|
$Test->skip_rest($reason);
|
|
|
|
-Like skip(), only it skips all the rest of the tests you plan to run
|
|
+Like C<skip()>, only it skips all the rest of the tests you plan to run
|
|
and terminates the test.
|
|
|
|
-If you're running under no_plan, it skips once and terminates the
|
|
+If you're running under C<no_plan>, it skips once and terminates the
|
|
test.
|
|
|
|
=end _unimplemented
|
|
@@ -896,13 +1042,13 @@
|
|
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
|
|
+Takes a quoted regular expression produced by C<qr//>, or a string
|
|
representing a regular expression.
|
|
|
|
Returns a Perl value which may be used instead of the corresponding
|
|
-regular expression, or undef if it's argument is not recognised.
|
|
+regular expression, or C<undef> if its argument is not recognised.
|
|
|
|
-For example, a version of like(), sans the useful diagnostic messages,
|
|
+For example, a version of C<like()>, sans the useful diagnostic messages,
|
|
could be written as:
|
|
|
|
sub laconic_like {
|
|
@@ -915,48 +1061,60 @@
|
|
|
|
=cut
|
|
|
|
-
|
|
sub maybe_regex {
|
|
- my ($self, $regex) = @_;
|
|
+ my( $self, $regex ) = @_;
|
|
my $usable_regex = undef;
|
|
|
|
return $usable_regex unless defined $regex;
|
|
|
|
- my($re, $opts);
|
|
+ my( $re, $opts );
|
|
|
|
# Check for qr/foo/
|
|
- if( ref $regex eq 'Regexp' ) {
|
|
+ if( _is_qr($regex) ) {
|
|
$usable_regex = $regex;
|
|
}
|
|
# Check for '/foo/' or 'm,foo,'
|
|
- elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
|
|
- (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
|
|
- )
|
|
+ elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
|
|
+ ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
|
|
+ )
|
|
{
|
|
$usable_regex = length $opts ? "(?$opts)$re" : $re;
|
|
}
|
|
|
|
return $usable_regex;
|
|
-};
|
|
+}
|
|
+
|
|
+sub _is_qr {
|
|
+ my $regex = shift;
|
|
+
|
|
+ # is_regexp() checks for regexes in a robust manner, say if they're
|
|
+ # blessed.
|
|
+ return re::is_regexp($regex) if defined &re::is_regexp;
|
|
+ return ref $regex eq 'Regexp';
|
|
+}
|
|
|
|
sub _regex_ok {
|
|
- my($self, $this, $regex, $cmp, $name) = @_;
|
|
+ my( $self, $this, $regex, $cmp, $name ) = @_;
|
|
|
|
- my $ok = 0;
|
|
+ my $ok = 0;
|
|
my $usable_regex = $self->maybe_regex($regex);
|
|
- unless (defined $usable_regex) {
|
|
+ unless( defined $usable_regex ) {
|
|
+ local $Level = $Level + 1;
|
|
$ok = $self->ok( 0, $name );
|
|
$self->diag(" '$regex' doesn't look much like a regex to me.");
|
|
return $ok;
|
|
}
|
|
|
|
{
|
|
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
+
|
|
my $test;
|
|
my $code = $self->_caller_context;
|
|
|
|
- local($@, $!, $SIG{__DIE__}); # isolate eval
|
|
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
|
|
|
|
- # Yes, it has to look like this or 5.4.5 won't see the #line 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};
|
|
@@ -967,10 +1125,12 @@
|
|
$ok = $self->ok( $test, $name );
|
|
}
|
|
|
|
- unless( $ok ) {
|
|
+ unless($ok) {
|
|
$this = defined $this ? "'$this'" : 'undef';
|
|
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
|
|
- $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
|
|
+
|
|
+ local $Level = $Level + 1;
|
|
+ $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
|
|
%s
|
|
%13s '%s'
|
|
DIAGNOSTIC
|
|
@@ -980,7 +1140,6 @@
|
|
return $ok;
|
|
}
|
|
|
|
-
|
|
# I'm not ready to publish this. It doesn't deal with array return
|
|
# values from the code or context.
|
|
|
|
@@ -991,23 +1150,33 @@
|
|
my $return_from_code = $Test->try(sub { code });
|
|
my($return_from_code, $error) = $Test->try(sub { code });
|
|
|
|
-Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
|
|
+Works like eval BLOCK except it ensures it has no effect on the rest
|
|
+of the test (ie. C<$@> is not set) nor is effected by outside
|
|
+interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
|
|
+Perls.
|
|
|
|
-$error is what would normally be in $@.
|
|
+C<$error> is what would normally be in C<$@>.
|
|
|
|
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;
|
|
+ my( $self, $code, %opts ) = @_;
|
|
+
|
|
+ my $error;
|
|
+ my $return;
|
|
+ {
|
|
+ local $!; # eval can mess up $!
|
|
+ local $@; # don't set $@ in the test
|
|
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
|
|
+ $return = eval { $code->() };
|
|
+ $error = $@;
|
|
+ }
|
|
+
|
|
+ die $error if $error and $opts{die_on_fail};
|
|
+
|
|
+ return wantarray ? ( $return, $error ) : $return;
|
|
}
|
|
|
|
=end private
|
|
@@ -1017,24 +1186,23 @@
|
|
|
|
my $is_fh = $Test->is_fh($thing);
|
|
|
|
-Determines if the given $thing can be used as a filehandle.
|
|
+Determines if the given C<$thing> can be used as a filehandle.
|
|
|
|
=cut
|
|
|
|
sub is_fh {
|
|
- my $self = shift;
|
|
+ my $self = shift;
|
|
my $maybe_fh = shift;
|
|
return 0 unless defined $maybe_fh;
|
|
|
|
- return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
|
|
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
|
|
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
|
|
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
|
|
|
|
return eval { $maybe_fh->isa("IO::Handle") } ||
|
|
# 5.5.4's tied() and can() doesn't like getting undef
|
|
- eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
|
|
+ eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
|
|
}
|
|
|
|
-
|
|
=back
|
|
|
|
|
|
@@ -1047,7 +1215,7 @@
|
|
|
|
$Test->level($how_high);
|
|
|
|
-How far up the call stack should $Test look when reporting where the
|
|
+How far up the call stack should C<$Test> look when reporting where the
|
|
test failed.
|
|
|
|
Defaults to 1.
|
|
@@ -1067,7 +1235,7 @@
|
|
=cut
|
|
|
|
sub level {
|
|
- my($self, $level) = @_;
|
|
+ my( $self, $level ) = @_;
|
|
|
|
if( defined $level ) {
|
|
$Level = $level;
|
|
@@ -1075,7 +1243,6 @@
|
|
return $Level;
|
|
}
|
|
|
|
-
|
|
=item B<use_numbers>
|
|
|
|
$Test->use_numbers($on_or_off);
|
|
@@ -1100,7 +1267,7 @@
|
|
=cut
|
|
|
|
sub use_numbers {
|
|
- my($self, $use_nums) = @_;
|
|
+ my( $self, $use_nums ) = @_;
|
|
|
|
if( defined $use_nums ) {
|
|
$self->{Use_Nums} = $use_nums;
|
|
@@ -1108,13 +1275,12 @@
|
|
return $self->{Use_Nums};
|
|
}
|
|
|
|
-
|
|
=item B<no_diag>
|
|
|
|
$Test->no_diag($no_diag);
|
|
|
|
If set true no diagnostics will be printed. This includes calls to
|
|
-diag().
|
|
+C<diag()>.
|
|
|
|
=item B<no_ending>
|
|
|
|
@@ -1137,7 +1303,7 @@
|
|
my $method = lc $attribute;
|
|
|
|
my $code = sub {
|
|
- my($self, $no) = @_;
|
|
+ my( $self, $no ) = @_;
|
|
|
|
if( defined $no ) {
|
|
$self->{$attribute} = $no;
|
|
@@ -1145,11 +1311,10 @@
|
|
return $self->{$attribute};
|
|
};
|
|
|
|
- no strict 'refs';
|
|
- *{__PACKAGE__.'::'.$method} = $code;
|
|
+ no strict 'refs'; ## no critic
|
|
+ *{ __PACKAGE__ . '::' . $method } = $code;
|
|
}
|
|
|
|
-
|
|
=back
|
|
|
|
=head2 Output
|
|
@@ -1165,11 +1330,11 @@
|
|
|
|
$Test->diag(@msgs);
|
|
|
|
-Prints out the given @msgs. Like C<print>, arguments are simply
|
|
+Prints out the given C<@msgs>. Like C<print>, arguments are simply
|
|
appended together.
|
|
|
|
-Normally, it uses the failure_output() handle, but if this is for a
|
|
-TODO test, the todo_output() handle is used.
|
|
+Normally, it uses the C<failure_output()> handle, but if this is for a
|
|
+TODO test, the C<todo_output()> handle is used.
|
|
|
|
Output will be indented and marked with a # so as not to interfere
|
|
with test output. A newline will be put on the end if there isn't one
|
|
@@ -1177,7 +1342,7 @@
|
|
|
|
We encourage using this rather than calling print directly.
|
|
|
|
-Returns false. Why? Because diag() is often used in conjunction with
|
|
+Returns false. Why? Because C<diag()> is often used in conjunction with
|
|
a failing test (C<ok() || diag()>) it "passes through" the failure.
|
|
|
|
return ok(...) || diag(...);
|
|
@@ -1188,7 +1353,35 @@
|
|
=cut
|
|
|
|
sub diag {
|
|
- my($self, @msgs) = @_;
|
|
+ my $self = shift;
|
|
+
|
|
+ $self->_print_comment( $self->_diag_fh, @_ );
|
|
+}
|
|
+
|
|
+=item B<note>
|
|
+
|
|
+ $Test->note(@msgs);
|
|
+
|
|
+Like C<diag()>, but it prints to the C<output()> handle so it will not
|
|
+normally be seen by the user except in verbose mode.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub note {
|
|
+ my $self = shift;
|
|
+
|
|
+ $self->_print_comment( $self->output, @_ );
|
|
+}
|
|
+
|
|
+sub _diag_fh {
|
|
+ my $self = shift;
|
|
+
|
|
+ local $Level = $Level + 1;
|
|
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
|
|
+}
|
|
+
|
|
+sub _print_comment {
|
|
+ my( $self, $fh, @msgs ) = @_;
|
|
|
|
return if $self->no_diag;
|
|
return unless @msgs;
|
|
@@ -1200,32 +1393,66 @@
|
|
# Convert undef to 'undef' so its readable.
|
|
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
|
|
|
|
- # Escape each line with a #.
|
|
- $msg =~ s/^/# /gm;
|
|
-
|
|
- # Stick a newline on the end if it needs it.
|
|
- $msg .= "\n" unless $msg =~ /\n\Z/;
|
|
+ # Escape the beginning, _print will take care of the rest.
|
|
+ $msg =~ s/^/# /;
|
|
|
|
local $Level = $Level + 1;
|
|
- $self->_print_diag($msg);
|
|
+ $self->_print_to_fh( $fh, $msg );
|
|
|
|
return 0;
|
|
}
|
|
|
|
+=item B<explain>
|
|
+
|
|
+ my @dump = $Test->explain(@msgs);
|
|
+
|
|
+Will dump the contents of any references in a human readable format.
|
|
+Handy for things like...
|
|
+
|
|
+ is_deeply($have, $want) || diag explain $have;
|
|
+
|
|
+or
|
|
+
|
|
+ is_deeply($have, $want) || note explain $have;
|
|
+
|
|
+=cut
|
|
+
|
|
+sub explain {
|
|
+ my $self = shift;
|
|
+
|
|
+ return map {
|
|
+ ref $_
|
|
+ ? do {
|
|
+ $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
|
|
+
|
|
+ my $dumper = Data::Dumper->new( [$_] );
|
|
+ $dumper->Indent(1)->Terse(1);
|
|
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
|
|
+ $dumper->Dump;
|
|
+ }
|
|
+ : $_
|
|
+ } @_;
|
|
+}
|
|
+
|
|
=begin _private
|
|
|
|
=item B<_print>
|
|
|
|
$Test->_print(@msgs);
|
|
|
|
-Prints to the output() filehandle.
|
|
+Prints to the C<output()> filehandle.
|
|
|
|
=end _private
|
|
|
|
=cut
|
|
|
|
sub _print {
|
|
- my($self, @msgs) = @_;
|
|
+ my $self = shift;
|
|
+ return $self->_print_to_fh( $self->output, @_ );
|
|
+}
|
|
+
|
|
+sub _print_to_fh {
|
|
+ my( $self, $fh, @msgs ) = @_;
|
|
|
|
# Prevent printing headers when only compiling. Mostly for when
|
|
# tests are deparsed with B::Deparse
|
|
@@ -1233,70 +1460,53 @@
|
|
|
|
my $msg = join '', @msgs;
|
|
|
|
- local($\, $", $,) = (undef, ' ', '');
|
|
- my $fh = $self->output;
|
|
+ local( $\, $", $, ) = ( undef, ' ', '' );
|
|
|
|
# Escape each line after the first with a # so we don't
|
|
# confuse Test::Harness.
|
|
- $msg =~ s/\n(.)/\n# $1/sg;
|
|
+ $msg =~ s{\n(?!\z)}{\n# }sg;
|
|
|
|
# Stick a newline on the end if it needs it.
|
|
- $msg .= "\n" unless $msg =~ /\n\Z/;
|
|
+ $msg .= "\n" unless $msg =~ /\n\z/;
|
|
|
|
- print $fh $msg;
|
|
+ return print $fh $msg;
|
|
}
|
|
|
|
-=begin private
|
|
-
|
|
-=item B<_print_diag>
|
|
-
|
|
- $Test->_print_diag(@msg);
|
|
-
|
|
-Like _print, but prints to the current diagnostic filehandle.
|
|
-
|
|
-=end private
|
|
-
|
|
-=cut
|
|
-
|
|
-sub _print_diag {
|
|
- my $self = shift;
|
|
-
|
|
- local($\, $", $,) = (undef, ' ', '');
|
|
- my $fh = $self->todo ? $self->todo_output : $self->failure_output;
|
|
- print $fh @_;
|
|
-}
|
|
-
|
|
=item B<output>
|
|
|
|
- $Test->output($fh);
|
|
- $Test->output($file);
|
|
+=item B<failure_output>
|
|
|
|
-Where normal "ok/not ok" test output should go.
|
|
+=item B<todo_output>
|
|
|
|
-Defaults to STDOUT.
|
|
+ my $filehandle = $Test->output;
|
|
+ $Test->output($filehandle);
|
|
+ $Test->output($filename);
|
|
+ $Test->output(\$scalar);
|
|
+
|
|
+These methods control where Test::Builder will print its output.
|
|
+They take either an open C<$filehandle>, a C<$filename> to open and write to
|
|
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
|
|
|
|
-=item B<failure_output>
|
|
+B<output> is where normal "ok/not ok" test output goes.
|
|
|
|
- $Test->failure_output($fh);
|
|
- $Test->failure_output($file);
|
|
+Defaults to STDOUT.
|
|
|
|
-Where diagnostic output on test failures and diag() should go.
|
|
+B<failure_output> is where diagnostic output on test failures and
|
|
+C<diag()> goes. It is normally not read by Test::Harness and instead is
|
|
+displayed to the user.
|
|
|
|
Defaults to STDERR.
|
|
|
|
-=item B<todo_output>
|
|
-
|
|
- $Test->todo_output($fh);
|
|
- $Test->todo_output($file);
|
|
-
|
|
-Where diagnostics about todo test failures and diag() should go.
|
|
+C<todo_output> is used instead of C<failure_output()> for the
|
|
+diagnostics of a failing TODO test. These will not be seen by the
|
|
+user.
|
|
|
|
Defaults to STDOUT.
|
|
|
|
=cut
|
|
|
|
sub output {
|
|
- my($self, $fh) = @_;
|
|
+ my( $self, $fh ) = @_;
|
|
|
|
if( defined $fh ) {
|
|
$self->{Out_FH} = $self->_new_fh($fh);
|
|
@@ -1305,7 +1515,7 @@
|
|
}
|
|
|
|
sub failure_output {
|
|
- my($self, $fh) = @_;
|
|
+ my( $self, $fh ) = @_;
|
|
|
|
if( defined $fh ) {
|
|
$self->{Fail_FH} = $self->_new_fh($fh);
|
|
@@ -1314,7 +1524,7 @@
|
|
}
|
|
|
|
sub todo_output {
|
|
- my($self, $fh) = @_;
|
|
+ my( $self, $fh ) = @_;
|
|
|
|
if( defined $fh ) {
|
|
$self->{Todo_FH} = $self->_new_fh($fh);
|
|
@@ -1322,7 +1532,6 @@
|
|
return $self->{Todo_FH};
|
|
}
|
|
|
|
-
|
|
sub _new_fh {
|
|
my $self = shift;
|
|
my($file_or_fh) = shift;
|
|
@@ -1331,24 +1540,37 @@
|
|
if( $self->is_fh($file_or_fh) ) {
|
|
$fh = $file_or_fh;
|
|
}
|
|
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
|
|
+ # Scalar refs as filehandles was added in 5.8.
|
|
+ if( $] >= 5.008 ) {
|
|
+ open $fh, ">>", $file_or_fh
|
|
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
|
|
+ }
|
|
+ # Emulate scalar ref filehandles with a tie.
|
|
+ else {
|
|
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
|
|
+ or $self->croak("Can't tie scalar ref $file_or_fh");
|
|
+ }
|
|
+ }
|
|
else {
|
|
- $fh = do { local *FH };
|
|
- open $fh, ">$file_or_fh" or
|
|
- $self->croak("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 _autoflush {
|
|
my($fh) = shift;
|
|
my $old_fh = select $fh;
|
|
$| = 1;
|
|
select $old_fh;
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
+my( $Testout, $Testerr );
|
|
|
|
sub _dup_stdhandles {
|
|
my $self = shift;
|
|
@@ -1357,41 +1579,80 @@
|
|
|
|
# Set everything to unbuffered else plain prints to STDOUT will
|
|
# come out in the wrong order from our own prints.
|
|
- _autoflush(\*TESTOUT);
|
|
- _autoflush(\*STDOUT);
|
|
- _autoflush(\*TESTERR);
|
|
- _autoflush(\*STDERR);
|
|
+ _autoflush($Testout);
|
|
+ _autoflush( \*STDOUT );
|
|
+ _autoflush($Testerr);
|
|
+ _autoflush( \*STDERR );
|
|
|
|
- $self->output(\*TESTOUT);
|
|
- $self->failure_output(\*TESTERR);
|
|
- $self->todo_output(\*TESTOUT);
|
|
-}
|
|
+ $self->reset_outputs;
|
|
|
|
+ return;
|
|
+}
|
|
|
|
-my $Opened_Testhandles = 0;
|
|
sub _open_testhandles {
|
|
- return if $Opened_Testhandles;
|
|
+ my $self = shift;
|
|
+
|
|
+ return if $self->{Opened_Testhandles};
|
|
+
|
|
# We dup STDOUT and STDERR so people can change them in their
|
|
# test suites while still getting normal test output.
|
|
- open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
|
|
- open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
|
|
- $Opened_Testhandles = 1;
|
|
+ open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
|
|
+ open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
|
|
+
|
|
+ # $self->_copy_io_layers( \*STDOUT, $Testout );
|
|
+ # $self->_copy_io_layers( \*STDERR, $Testerr );
|
|
+
|
|
+ $self->{Opened_Testhandles} = 1;
|
|
+
|
|
+ return;
|
|
+}
|
|
+
|
|
+sub _copy_io_layers {
|
|
+ my( $self, $src, $dst ) = @_;
|
|
+
|
|
+ $self->_try(
|
|
+ sub {
|
|
+ require PerlIO;
|
|
+ my @src_layers = PerlIO::get_layers($src);
|
|
+
|
|
+ binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
|
|
+ }
|
|
+ );
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
+=item reset_outputs
|
|
+
|
|
+ $tb->reset_outputs;
|
|
+
|
|
+Resets all the output filehandles back to their defaults.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub reset_outputs {
|
|
+ my $self = shift;
|
|
+
|
|
+ $self->output ($Testout);
|
|
+ $self->failure_output($Testerr);
|
|
+ $self->todo_output ($Testout);
|
|
+
|
|
+ return;
|
|
+}
|
|
|
|
=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>).
|
|
+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>).
|
|
+point where the original test function was called (C<< $tb->caller >>).
|
|
|
|
=cut
|
|
|
|
@@ -1399,28 +1660,20 @@
|
|
my $self = shift;
|
|
|
|
local $Level = $Level + 1;
|
|
- my($pack, $file, $line) = $self->caller;
|
|
- return join("", @_) . " at $file line $line.\n";
|
|
+ my( $pack, $file, $line ) = $self->caller;
|
|
+ return join( "", @_ ) . " at $file line $line.\n";
|
|
}
|
|
|
|
sub carp {
|
|
my $self = shift;
|
|
- warn $self->_message_at_caller(@_);
|
|
+ return warn $self->_message_at_caller(@_);
|
|
}
|
|
|
|
sub croak {
|
|
my $self = shift;
|
|
- die $self->_message_at_caller(@_);
|
|
+ return die $self->_message_at_caller(@_);
|
|
}
|
|
|
|
-sub _plan_check {
|
|
- my $self = shift;
|
|
-
|
|
- unless( $self->{Have_Plan} ) {
|
|
- local $Level = $Level + 2;
|
|
- $self->croak("You tried to run a test without a plan");
|
|
- }
|
|
-}
|
|
|
|
=back
|
|
|
|
@@ -1444,28 +1697,26 @@
|
|
=cut
|
|
|
|
sub current_test {
|
|
- my($self, $num) = @_;
|
|
+ my( $self, $num ) = @_;
|
|
|
|
- lock($self->{Curr_Test});
|
|
+ lock( $self->{Curr_Test} );
|
|
if( defined $num ) {
|
|
- unless( $self->{Have_Plan} ) {
|
|
- $self->croak("Can't change the current test number without a plan!");
|
|
- }
|
|
-
|
|
$self->{Curr_Test} = $num;
|
|
|
|
# If the test counter is being pushed forward fill in the details.
|
|
my $test_results = $self->{Test_Results};
|
|
if( $num > @$test_results ) {
|
|
my $start = @$test_results ? @$test_results : 0;
|
|
- for ($start..$num-1) {
|
|
- $test_results->[$_] = &share({
|
|
- 'ok' => 1,
|
|
- actual_ok => undef,
|
|
- reason => 'incrementing test number',
|
|
- type => 'unknown',
|
|
- name => undef
|
|
- });
|
|
+ for( $start .. $num - 1 ) {
|
|
+ $test_results->[$_] = &share(
|
|
+ {
|
|
+ 'ok' => 1,
|
|
+ actual_ok => undef,
|
|
+ reason => 'incrementing test number',
|
|
+ type => 'unknown',
|
|
+ name => undef
|
|
+ }
|
|
+ );
|
|
}
|
|
}
|
|
# If backward, wipe history. Its their funeral.
|
|
@@ -1476,7 +1727,6 @@
|
|
return $self->{Curr_Test};
|
|
}
|
|
|
|
-
|
|
=item B<summary>
|
|
|
|
my @tests = $Test->summary;
|
|
@@ -1498,7 +1748,7 @@
|
|
|
|
my @tests = $Test->details;
|
|
|
|
-Like summary(), but with a lot more detail.
|
|
+Like C<summary()>, but with a lot more detail.
|
|
|
|
$tests[$test_num - 1] =
|
|
{ 'ok' => is the test considered a pass?
|
|
@@ -1512,7 +1762,7 @@
|
|
|
|
'actual_ok' is a reflection of whether or not the test literally
|
|
printed 'ok' or 'not ok'. This is for examining the result of 'todo'
|
|
-tests.
|
|
+tests.
|
|
|
|
'name' is the name of the test.
|
|
|
|
@@ -1525,16 +1775,16 @@
|
|
unknown see below
|
|
|
|
Sometimes the Test::Builder test counter is incremented without it
|
|
-printing any test output, for example, when current_test() is changed.
|
|
+printing any test output, for example, when C<current_test()> is changed.
|
|
In these cases, Test::Builder doesn't know the result of the test, so
|
|
-it's type is 'unkown'. These details for these tests are filled in.
|
|
-They are considered ok, but the name and actual_ok is left undef.
|
|
+its type is 'unknown'. These details for these tests are filled in.
|
|
+They are considered ok, but the name and actual_ok is left C<undef>.
|
|
|
|
For example "not ok 23 - hole count # TODO insufficient donuts" would
|
|
result in this structure:
|
|
|
|
$tests[22] = # 23 - 1, since arrays start from 0.
|
|
- { ok => 1, # logically, the test passed since it's todo
|
|
+ { ok => 1, # logically, the test passed since its todo
|
|
actual_ok => 0, # in absolute terms, it failed
|
|
name => 'hole count',
|
|
type => 'todo',
|
|
@@ -1553,30 +1803,154 @@
|
|
my $todo_reason = $Test->todo;
|
|
my $todo_reason = $Test->todo($pack);
|
|
|
|
-todo() looks for a $TODO variable in your tests. If set, all tests
|
|
-will be considered 'todo' (see Test::More and Test::Harness for
|
|
-details). Returns the reason (ie. the value of $TODO) if running as
|
|
-todo tests, false otherwise.
|
|
-
|
|
-todo() is about finding the right package to look for $TODO in. It
|
|
-uses the exported_to() package to find it. If that's not set, it's
|
|
-pretty good at guessing the right package to look at based on $Level.
|
|
+If the current tests are considered "TODO" it will return the reason,
|
|
+if any. This reason can come from a C<$TODO> variable or the last call
|
|
+to C<todo_start()>.
|
|
+
|
|
+Since a TODO test does not need a reason, this function can return an
|
|
+empty string even when inside a TODO block. Use C<< $Test->in_todo >>
|
|
+to determine if you are currently inside a TODO block.
|
|
+
|
|
+C<todo()> is about finding the right package to look for C<$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
|
|
+for the C<$TODO> variable. If you want to be sure, tell it explicitly
|
|
what $pack to use.
|
|
|
|
=cut
|
|
|
|
sub todo {
|
|
- my($self, $pack) = @_;
|
|
+ my( $self, $pack ) = @_;
|
|
+
|
|
+ return $self->{Todo} if defined $self->{Todo};
|
|
|
|
- $pack = $pack || $self->exported_to || $self->caller($Level);
|
|
- return 0 unless $pack;
|
|
+ local $Level = $Level + 1;
|
|
+ my $todo = $self->find_TODO($pack);
|
|
+ return $todo if defined $todo;
|
|
|
|
- no strict 'refs';
|
|
- return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
|
|
- : 0;
|
|
+ return '';
|
|
+}
|
|
+
|
|
+=item B<find_TODO>
|
|
+
|
|
+ my $todo_reason = $Test->find_TODO();
|
|
+ my $todo_reason = $Test->find_TODO($pack):
|
|
+
|
|
+Like C<todo()> but only returns the value of C<$TODO> ignoring
|
|
+C<todo_start()>.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub find_TODO {
|
|
+ my( $self, $pack ) = @_;
|
|
+
|
|
+ $pack = $pack || $self->caller(1) || $self->exported_to;
|
|
+ return unless $pack;
|
|
+
|
|
+ no strict 'refs'; ## no critic
|
|
+ return ${ $pack . '::TODO' };
|
|
+}
|
|
+
|
|
+=item B<in_todo>
|
|
+
|
|
+ my $in_todo = $Test->in_todo;
|
|
+
|
|
+Returns true if the test is currently inside a TODO block.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub in_todo {
|
|
+ my $self = shift;
|
|
+
|
|
+ local $Level = $Level + 1;
|
|
+ return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
|
|
+}
|
|
+
|
|
+=item B<todo_start>
|
|
+
|
|
+ $Test->todo_start();
|
|
+ $Test->todo_start($message);
|
|
+
|
|
+This method allows you declare all subsequent tests as TODO tests, up until
|
|
+the C<todo_end> method has been called.
|
|
+
|
|
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
|
|
+whether or not we're in a TODO test. However, often we find that this is not
|
|
+possible to determine (such as when we want to use C<$TODO> but
|
|
+the tests are being executed in other packages which can't be inferred
|
|
+beforehand).
|
|
+
|
|
+Note that you can use this to nest "todo" tests
|
|
+
|
|
+ $Test->todo_start('working on this');
|
|
+ # lots of code
|
|
+ $Test->todo_start('working on that');
|
|
+ # more code
|
|
+ $Test->todo_end;
|
|
+ $Test->todo_end;
|
|
+
|
|
+This is generally not recommended, but large testing systems often have weird
|
|
+internal needs.
|
|
+
|
|
+We've tried to make this also work with the TODO: syntax, but it's not
|
|
+guaranteed and its use is also discouraged:
|
|
+
|
|
+ TODO: {
|
|
+ local $TODO = 'We have work to do!';
|
|
+ $Test->todo_start('working on this');
|
|
+ # lots of code
|
|
+ $Test->todo_start('working on that');
|
|
+ # more code
|
|
+ $Test->todo_end;
|
|
+ $Test->todo_end;
|
|
+ }
|
|
+
|
|
+Pick one style or another of "TODO" to be on the safe side.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub todo_start {
|
|
+ my $self = shift;
|
|
+ my $message = @_ ? shift : '';
|
|
+
|
|
+ $self->{Start_Todo}++;
|
|
+ if( $self->in_todo ) {
|
|
+ push @{ $self->{Todo_Stack} } => $self->todo;
|
|
+ }
|
|
+ $self->{Todo} = $message;
|
|
+
|
|
+ return;
|
|
+}
|
|
+
|
|
+=item C<todo_end>
|
|
+
|
|
+ $Test->todo_end;
|
|
+
|
|
+Stops running tests as "TODO" tests. This method is fatal if called without a
|
|
+preceding C<todo_start> method call.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub todo_end {
|
|
+ my $self = shift;
|
|
+
|
|
+ if( !$self->{Start_Todo} ) {
|
|
+ $self->croak('todo_end() called without todo_start()');
|
|
+ }
|
|
+
|
|
+ $self->{Start_Todo}--;
|
|
+
|
|
+ if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
|
|
+ $self->{Todo} = pop @{ $self->{Todo_Stack} };
|
|
+ }
|
|
+ else {
|
|
+ delete $self->{Todo};
|
|
+ }
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
=item B<caller>
|
|
@@ -1585,15 +1959,24 @@
|
|
my($pack, $file, $line) = $Test->caller;
|
|
my($pack, $file, $line) = $Test->caller($height);
|
|
|
|
-Like the normal caller(), except it reports according to your level().
|
|
+Like the normal C<caller()>, except it reports according to your C<level()>.
|
|
+
|
|
+C<$height> will be added to the C<level()>.
|
|
+
|
|
+If C<caller()> winds up off the top of the stack it report the highest context.
|
|
|
|
=cut
|
|
|
|
-sub caller {
|
|
- my($self, $height) = @_;
|
|
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
|
|
+ my( $self, $height ) = @_;
|
|
$height ||= 0;
|
|
|
|
- my @caller = CORE::caller($self->level + $height + 1);
|
|
+ my $level = $self->level + $height + 1;
|
|
+ my @caller;
|
|
+ do {
|
|
+ @caller = CORE::caller( $level );
|
|
+ $level--;
|
|
+ } until @caller;
|
|
return wantarray ? @caller : $caller[0];
|
|
}
|
|
|
|
@@ -1619,126 +2002,116 @@
|
|
sub _sanity_check {
|
|
my $self = shift;
|
|
|
|
- $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
|
|
- $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
|
|
- 'Somehow your tests ran without a plan!');
|
|
- $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
|
|
- 'Somehow you got a different number of results than tests ran!');
|
|
+ $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
|
|
+ $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
|
|
+ 'Somehow you got a different number of results than tests ran!' );
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
=item B<_whoa>
|
|
|
|
$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
|
|
+A sanity check, similar to C<assert()>. If the C<$check> is true, something
|
|
+has gone horribly wrong. It will die with the given C<$description> and
|
|
a note to contact the author.
|
|
|
|
=cut
|
|
|
|
sub _whoa {
|
|
- my($self, $check, $desc) = @_;
|
|
- if( $check ) {
|
|
+ my( $self, $check, $desc ) = @_;
|
|
+ if($check) {
|
|
local $Level = $Level + 1;
|
|
$self->croak(<<"WHOA");
|
|
WHOA! $desc
|
|
This should never happen! Please contact the author immediately!
|
|
WHOA
|
|
}
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
=item B<_my_exit>
|
|
|
|
_my_exit($exit_num);
|
|
|
|
-Perl seems to have some trouble with exiting inside an END block. 5.005_03
|
|
-and 5.6.1 both seem to do odd things. Instead, this function edits $?
|
|
-directly. It should ONLY be called from inside an END block. It
|
|
+Perl seems to have some trouble with exiting inside an C<END> block. 5.005_03
|
|
+and 5.6.1 both seem to do odd things. Instead, this function edits C<$?>
|
|
+directly. It should B<only> be called from inside an C<END> block. It
|
|
doesn't actually exit, that's your job.
|
|
|
|
=cut
|
|
|
|
sub _my_exit {
|
|
- $? = $_[0];
|
|
+ $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
|
|
|
|
return 1;
|
|
}
|
|
|
|
-
|
|
=back
|
|
|
|
=end _private
|
|
|
|
=cut
|
|
|
|
-$SIG{__DIE__} = sub {
|
|
- # We don't want to muck with death in an eval, but $^S isn't
|
|
- # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
|
|
- # with it. Instead, we use caller. This also means it runs under
|
|
- # 5.004!
|
|
- my $in_eval = 0;
|
|
- for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
|
|
- $in_eval = 1 if $sub =~ /^\(eval\)/;
|
|
- }
|
|
- $Test->{Test_Died} = 1 unless $in_eval;
|
|
-};
|
|
-
|
|
sub _ending {
|
|
my $self = shift;
|
|
|
|
- $self->_sanity_check();
|
|
+ my $real_exit_code = $?;
|
|
|
|
# Don't bother with an ending if this is a forked copy. Only the parent
|
|
# should do the ending.
|
|
- # Exit if plan() was never called. This is so "require Test::Simple"
|
|
+ if( $self->{Original_Pid} != $$ ) {
|
|
+ return;
|
|
+ }
|
|
+
|
|
+ # Ran tests but never declared a plan or hit done_testing
|
|
+ if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
|
|
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
|
|
+ }
|
|
+
|
|
+ # 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.
|
|
my $test_results = $self->{Test_Results};
|
|
- if( @$test_results ) {
|
|
+ if(@$test_results) {
|
|
# The plan? We have no plan.
|
|
if( $self->{No_Plan} ) {
|
|
- $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
|
|
+ $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
|
|
$self->{Expected_Tests} = $self->{Curr_Test};
|
|
}
|
|
|
|
# Auto-extended arrays and elements which aren't explicitly
|
|
# filled in with a shared reference will puke under 5.8.0
|
|
# ithreads. So we have to fill them in by hand. :(
|
|
- my $empty_result = &share({});
|
|
- for my $idx ( 0..$self->{Expected_Tests}-1 ) {
|
|
+ my $empty_result = &share( {} );
|
|
+ for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
|
|
$test_results->[$idx] = $empty_result
|
|
unless defined $test_results->[$idx];
|
|
}
|
|
|
|
- my $num_failed = grep !$_->{'ok'},
|
|
- @{$test_results}[0..$self->{Curr_Test}-1];
|
|
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
|
|
|
|
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
|
|
|
|
- if( $num_extra < 0 ) {
|
|
- my $s = $self->{Expected_Tests} == 1 ? '' : 's';
|
|
- $self->diag(<<"FAIL");
|
|
-Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
|
|
-FAIL
|
|
- }
|
|
- elsif( $num_extra > 0 ) {
|
|
+ if( $num_extra != 0 ) {
|
|
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
|
|
$self->diag(<<"FAIL");
|
|
-Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
|
|
+Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
|
|
FAIL
|
|
}
|
|
|
|
- if ( $num_failed ) {
|
|
+ if($num_failed) {
|
|
my $num_tests = $self->{Curr_Test};
|
|
my $s = $num_failed == 1 ? '' : 's';
|
|
|
|
@@ -1749,16 +2122,16 @@
|
|
FAIL
|
|
}
|
|
|
|
- if( $self->{Test_Died} ) {
|
|
+ if($real_exit_code) {
|
|
$self->diag(<<"FAIL");
|
|
-Looks like your test died just after $self->{Curr_Test}.
|
|
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
|
|
FAIL
|
|
|
|
- _my_exit( 255 ) && return;
|
|
+ _my_exit($real_exit_code) && return;
|
|
}
|
|
|
|
my $exit_code;
|
|
- if( $num_failed ) {
|
|
+ if($num_failed) {
|
|
$exit_code = $num_failed <= 254 ? $num_failed : 254;
|
|
}
|
|
elsif( $num_extra != 0 ) {
|
|
@@ -1768,21 +2141,23 @@
|
|
$exit_code = 0;
|
|
}
|
|
|
|
- _my_exit( $exit_code ) && return;
|
|
+ _my_exit($exit_code) && return;
|
|
}
|
|
- elsif ( $self->{Skip_All} ) {
|
|
- _my_exit( 0 ) && return;
|
|
+ elsif( $self->{Skip_All} ) {
|
|
+ _my_exit(0) && return;
|
|
}
|
|
- elsif ( $self->{Test_Died} ) {
|
|
- $self->diag(<<'FAIL');
|
|
-Looks like your test died before it could output anything.
|
|
+ elsif($real_exit_code) {
|
|
+ $self->diag(<<"FAIL");
|
|
+Looks like your test exited with $real_exit_code before it could output anything.
|
|
FAIL
|
|
- _my_exit( 255 ) && return;
|
|
+ _my_exit($real_exit_code) && return;
|
|
}
|
|
else {
|
|
$self->diag("No tests run!\n");
|
|
- _my_exit( 255 ) && return;
|
|
+ _my_exit(255) && return;
|
|
}
|
|
+
|
|
+ $self->_whoa( 1, "We fell off the end of _ending()" );
|
|
}
|
|
|
|
END {
|
|
@@ -1807,12 +2182,11 @@
|
|
|
|
If you fail more than 254 tests, it will be reported as 254.
|
|
|
|
-
|
|
=head1 THREADS
|
|
|
|
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.
|
|
+the test number using C<current_test()> they will all be effected.
|
|
|
|
While versions earlier than 5.8.1 had threads they contain too many
|
|
bugs to support.
|
|
@@ -1820,6 +2194,21 @@
|
|
Test::Builder is only thread-aware if threads.pm is loaded I<before>
|
|
Test::Builder.
|
|
|
|
+=head1 MEMORY
|
|
+
|
|
+An informative hash, accessable via C<<details()>>, is stored for each
|
|
+test you perform. So memory usage will scale linearly with each test
|
|
+run. Although this is not a problem for most test suites, it can
|
|
+become an issue if you do large (hundred thousands to million)
|
|
+combinatorics tests in the same run.
|
|
+
|
|
+In such cases, you are advised to either split the test file into smaller
|
|
+ones, or use a reverse approach, doing "normal" (code) compares and
|
|
+triggering fail() should anything go unexpected.
|
|
+
|
|
+Future versions of Test::Builder will have a way to turn history off.
|
|
+
|
|
+
|
|
=head1 EXAMPLES
|
|
|
|
CPAN can provide the best examples. Test::Simple, Test::More,
|
|
@@ -1836,10 +2225,10 @@
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
-Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
|
|
- Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
|
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
|
|
+ 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>
|
|
@@ -1847,3 +2236,4 @@
|
|
=cut
|
|
|
|
1;
|
|
+
|
|
diff -urN perl-5.10.0.orig/lib/Test/More.pm perl-5.10.0/lib/Test/More.pm
|
|
--- perl-5.10.0.orig/lib/Test/More.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/More.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,39 +1,40 @@
|
|
package Test::More;
|
|
|
|
-use 5.004;
|
|
-
|
|
+use 5.006;
|
|
use strict;
|
|
+use warnings;
|
|
+
|
|
+#---- perlcritic exemptions. ----#
|
|
|
|
+# We use a lot of subroutine prototypes
|
|
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
|
|
|
|
# Can't use Carp because it might cause use_ok() to accidentally succeed
|
|
# even though the module being used forgot to use Carp. Yes, this
|
|
# actually happened.
|
|
sub _carp {
|
|
- my($file, $line) = (caller(1))[1,2];
|
|
- warn @_, " at $file line $line\n";
|
|
+ my( $file, $line ) = ( caller(1) )[ 1, 2 ];
|
|
+ return warn @_, " at $file line $line\n";
|
|
}
|
|
|
|
-
|
|
-
|
|
-use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
|
|
-$VERSION = '0.72';
|
|
-$VERSION = eval $VERSION; # make the alpha version come out as a number
|
|
+our $VERSION = '0.92';
|
|
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
|
|
use Test::Builder::Module;
|
|
-@ISA = qw(Test::Builder::Module);
|
|
-@EXPORT = qw(ok use_ok require_ok
|
|
- is isnt like unlike is_deeply
|
|
- cmp_ok
|
|
- skip todo todo_skip
|
|
- pass fail
|
|
- eq_array eq_hash eq_set
|
|
- $TODO
|
|
- plan
|
|
- can_ok isa_ok
|
|
- diag
|
|
- BAIL_OUT
|
|
- );
|
|
-
|
|
+our @ISA = qw(Test::Builder::Module);
|
|
+our @EXPORT = qw(ok use_ok require_ok
|
|
+ is isnt like unlike is_deeply
|
|
+ cmp_ok
|
|
+ skip todo todo_skip
|
|
+ pass fail
|
|
+ eq_array eq_hash eq_set
|
|
+ $TODO
|
|
+ plan
|
|
+ done_testing
|
|
+ can_ok isa_ok new_ok
|
|
+ diag note explain
|
|
+ BAIL_OUT
|
|
+);
|
|
|
|
=head1 NAME
|
|
|
|
@@ -43,9 +44,9 @@
|
|
|
|
use Test::More tests => 23;
|
|
# or
|
|
- use Test::More qw(no_plan);
|
|
- # or
|
|
use Test::More skip_all => $reason;
|
|
+ # or
|
|
+ use Test::More; # see done_testing()
|
|
|
|
BEGIN { use_ok( 'Some::Module' ); }
|
|
require_ok( 'Some::Module' );
|
|
@@ -95,7 +96,7 @@
|
|
=head1 DESCRIPTION
|
|
|
|
B<STOP!> If you're just getting started writing tests, have a look at
|
|
-Test::Simple first. This is a drop in replacement for Test::Simple
|
|
+L<Test::Simple> first. This is a drop in replacement for Test::Simple
|
|
which you can switch to once you get the hang of basic testing.
|
|
|
|
The purpose of this module is to provide a wide range of testing
|
|
@@ -115,14 +116,19 @@
|
|
|
|
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
|
|
-have no plan. (Try to avoid using this as it weakens your test.)
|
|
+There are cases when you will not know beforehand how many tests your
|
|
+script is going to run. In this case, you can declare your tests at
|
|
+the end.
|
|
+
|
|
+ use Test::More;
|
|
+
|
|
+ ... run your tests ...
|
|
|
|
- use Test::More qw(no_plan);
|
|
+ done_testing( $number_of_tests_run );
|
|
|
|
-B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
|
|
-think everything has failed. See L<CAVEATS and NOTES>).
|
|
+Sometimes you really don't know how many tests were run, or it's too
|
|
+difficult to calculate. In which case you can leave off
|
|
+$number_of_tests_run.
|
|
|
|
In some cases, you'll want to completely skip an entire testing script.
|
|
|
|
@@ -159,10 +165,9 @@
|
|
sub plan {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->plan(@_);
|
|
+ return $tb->plan(@_);
|
|
}
|
|
|
|
-
|
|
# This implements "use Test::More 'no_diag'" but the behavior is
|
|
# deprecated.
|
|
sub import_extra {
|
|
@@ -170,7 +175,7 @@
|
|
my $list = shift;
|
|
|
|
my @other = ();
|
|
- my $idx = 0;
|
|
+ my $idx = 0;
|
|
while( $idx <= $#{$list} ) {
|
|
my $item = $list->[$idx];
|
|
|
|
@@ -185,8 +190,35 @@
|
|
}
|
|
|
|
@$list = @other;
|
|
+
|
|
+ return;
|
|
}
|
|
|
|
+=over 4
|
|
+
|
|
+=item B<done_testing>
|
|
+
|
|
+ done_testing();
|
|
+ done_testing($number_of_tests);
|
|
+
|
|
+If you don't know how many tests you're going to run, you can issue
|
|
+the plan when you're done running tests.
|
|
+
|
|
+$number_of_tests is the same as plan(), it's the number of tests you
|
|
+expected to run. You can omit this, in which case the number of tests
|
|
+you ran doesn't matter, just the fact that your tests ran to
|
|
+conclusion.
|
|
+
|
|
+This is safer than and replaces the "no_plan" plan.
|
|
+
|
|
+=back
|
|
+
|
|
+=cut
|
|
+
|
|
+sub done_testing {
|
|
+ my $tb = Test::More->builder;
|
|
+ $tb->done_testing(@_);
|
|
+}
|
|
|
|
=head2 Test names
|
|
|
|
@@ -257,10 +289,10 @@
|
|
=cut
|
|
|
|
sub ok ($;$) {
|
|
- my($test, $name) = @_;
|
|
+ my( $test, $name ) = @_;
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->ok($test, $name);
|
|
+ return $tb->ok( $test, $name );
|
|
}
|
|
|
|
=item B<is>
|
|
@@ -318,6 +350,17 @@
|
|
|
|
ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
|
|
|
|
+A simple call to isnt() usually does not provide a strong test but there
|
|
+are cases when you cannot say much more about a value than that it is
|
|
+different from some other value:
|
|
+
|
|
+ new_ok $obj, "Foo";
|
|
+
|
|
+ my $clone = $obj->clone;
|
|
+ isa_ok $obj, "Foo", "Foo->clone";
|
|
+
|
|
+ isnt $obj, $clone, "clone() produces a different object";
|
|
+
|
|
For those grammatical pedants out there, there's an C<isn't()>
|
|
function which is an alias of isnt().
|
|
|
|
@@ -326,18 +369,17 @@
|
|
sub is ($$;$) {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->is_eq(@_);
|
|
+ return $tb->is_eq(@_);
|
|
}
|
|
|
|
sub isnt ($$;$) {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->isnt_eq(@_);
|
|
+ return $tb->isnt_eq(@_);
|
|
}
|
|
|
|
*isn't = \&isnt;
|
|
|
|
-
|
|
=item B<like>
|
|
|
|
like( $got, qr/expected/, $test_name );
|
|
@@ -371,10 +413,9 @@
|
|
sub like ($$;$) {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->like(@_);
|
|
+ return $tb->like(@_);
|
|
}
|
|
|
|
-
|
|
=item B<unlike>
|
|
|
|
unlike( $got, qr/expected/, $test_name );
|
|
@@ -387,10 +428,9 @@
|
|
sub unlike ($$;$) {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->unlike(@_);
|
|
+ return $tb->unlike(@_);
|
|
}
|
|
|
|
-
|
|
=item B<cmp_ok>
|
|
|
|
cmp_ok( $got, $op, $expected, $test_name );
|
|
@@ -422,15 +462,20 @@
|
|
|
|
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
|
|
|
|
+It's especially useful when comparing greater-than or smaller-than
|
|
+relation between values:
|
|
+
|
|
+ cmp_ok( $some_value, '<=', $upper_limit );
|
|
+
|
|
+
|
|
=cut
|
|
|
|
sub cmp_ok($$$;$) {
|
|
my $tb = Test::More->builder;
|
|
|
|
- $tb->cmp_ok(@_);
|
|
+ return $tb->cmp_ok(@_);
|
|
}
|
|
|
|
-
|
|
=item B<can_ok>
|
|
|
|
can_ok($module, @methods);
|
|
@@ -461,17 +506,17 @@
|
|
=cut
|
|
|
|
sub can_ok ($@) {
|
|
- my($proto, @methods) = @_;
|
|
+ my( $proto, @methods ) = @_;
|
|
my $class = ref $proto || $proto;
|
|
my $tb = Test::More->builder;
|
|
|
|
- unless( $class ) {
|
|
+ unless($class) {
|
|
my $ok = $tb->ok( 0, "->can(...)" );
|
|
$tb->diag(' can_ok() called with empty class or reference');
|
|
return $ok;
|
|
}
|
|
|
|
- unless( @methods ) {
|
|
+ unless(@methods) {
|
|
my $ok = $tb->ok( 0, "$class->can(...)" );
|
|
$tb->diag(' can_ok() called with no methods');
|
|
return $ok;
|
|
@@ -479,24 +524,24 @@
|
|
|
|
my @nok = ();
|
|
foreach my $method (@methods) {
|
|
- $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
|
|
+ $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
|
|
}
|
|
|
|
- my $name;
|
|
- $name = @methods == 1 ? "$class->can('$methods[0]')"
|
|
- : "$class->can(...)";
|
|
+ my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
|
|
+ "$class->can(...)" ;
|
|
|
|
my $ok = $tb->ok( !@nok, $name );
|
|
|
|
- $tb->diag(map " $class->can('$_') failed\n", @nok);
|
|
+ $tb->diag( map " $class->can('$_') failed\n", @nok );
|
|
|
|
return $ok;
|
|
}
|
|
|
|
=item B<isa_ok>
|
|
|
|
- isa_ok($object, $class, $object_name);
|
|
- isa_ok($ref, $type, $ref_name);
|
|
+ isa_ok($object, $class, $object_name);
|
|
+ isa_ok($subclass, $class, $object_name);
|
|
+ isa_ok($ref, $type, $ref_name);
|
|
|
|
Checks to see if the given C<< $object->isa($class) >>. Also checks to make
|
|
sure the object was defined in the first place. Handy for this sort
|
|
@@ -512,6 +557,10 @@
|
|
|
|
to safeguard against your test script blowing up.
|
|
|
|
+You can also test a class, to make sure that it has the right ancestor:
|
|
+
|
|
+ isa_ok( 'Vole', 'Rodent' );
|
|
+
|
|
It works on references, too:
|
|
|
|
isa_ok( $array_ref, 'ARRAY' );
|
|
@@ -523,46 +572,52 @@
|
|
=cut
|
|
|
|
sub isa_ok ($$;$) {
|
|
- my($object, $class, $obj_name) = @_;
|
|
+ my( $object, $class, $obj_name ) = @_;
|
|
my $tb = Test::More->builder;
|
|
|
|
my $diag;
|
|
- $obj_name = 'The object' unless defined $obj_name;
|
|
- my $name = "$obj_name isa $class";
|
|
+
|
|
if( !defined $object ) {
|
|
+ $obj_name = 'The thing' unless defined $obj_name;
|
|
$diag = "$obj_name isn't defined";
|
|
}
|
|
- elsif( !ref $object ) {
|
|
- $diag = "$obj_name isn't a reference";
|
|
- }
|
|
else {
|
|
+ my $whatami = ref $object ? 'object' : 'class';
|
|
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
|
|
- my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
|
|
- if( $error ) {
|
|
+ my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
|
|
+ if($error) {
|
|
if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
|
|
# Its an unblessed reference
|
|
- if( !UNIVERSAL::isa($object, $class) ) {
|
|
+ $obj_name = 'The reference' unless defined $obj_name;
|
|
+ if( !UNIVERSAL::isa( $object, $class ) ) {
|
|
my $ref = ref $object;
|
|
$diag = "$obj_name isn't a '$class' it's a '$ref'";
|
|
}
|
|
- } else {
|
|
+ }
|
|
+ elsif( $error =~ /Can't call method "isa" without a package/ ) {
|
|
+ # It's something that can't even be a class
|
|
+ $diag = "$obj_name isn't a class or reference";
|
|
+ }
|
|
+ else {
|
|
die <<WHOA;
|
|
-WHOA! I tried to call ->isa on your object and got some weird error.
|
|
+WHOA! I tried to call ->isa on your $whatami and got some weird error.
|
|
Here's the error.
|
|
$error
|
|
WHOA
|
|
}
|
|
}
|
|
- elsif( !$rslt ) {
|
|
- my $ref = ref $object;
|
|
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
|
|
+ else {
|
|
+ $obj_name = "The $whatami" unless defined $obj_name;
|
|
+ if( !$rslt ) {
|
|
+ my $ref = ref $object;
|
|
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
|
|
+ }
|
|
}
|
|
}
|
|
-
|
|
-
|
|
|
|
+ my $name = "$obj_name isa $class";
|
|
my $ok;
|
|
- if( $diag ) {
|
|
+ if($diag) {
|
|
$ok = $tb->ok( 0, $name );
|
|
$tb->diag(" $diag\n");
|
|
}
|
|
@@ -573,6 +628,49 @@
|
|
return $ok;
|
|
}
|
|
|
|
+=item B<new_ok>
|
|
+
|
|
+ my $obj = new_ok( $class );
|
|
+ my $obj = new_ok( $class => \@args );
|
|
+ my $obj = new_ok( $class => \@args, $object_name );
|
|
+
|
|
+A convenience function which combines creating an object and calling
|
|
+isa_ok() on that object.
|
|
+
|
|
+It is basically equivalent to:
|
|
+
|
|
+ my $obj = $class->new(@args);
|
|
+ isa_ok $obj, $class, $object_name;
|
|
+
|
|
+If @args is not given, an empty list will be used.
|
|
+
|
|
+This function only works on new() and it assumes new() will return
|
|
+just a single object which isa C<$class>.
|
|
+
|
|
+=cut
|
|
+
|
|
+sub new_ok {
|
|
+ my $tb = Test::More->builder;
|
|
+ $tb->croak("new_ok() must be given at least a class") unless @_;
|
|
+
|
|
+ my( $class, $args, $object_name ) = @_;
|
|
+
|
|
+ $args ||= [];
|
|
+ $object_name = "The object" unless defined $object_name;
|
|
+
|
|
+ my $obj;
|
|
+ my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
|
|
+ if($success) {
|
|
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
|
|
+ isa_ok $obj, $class, $object_name;
|
|
+ }
|
|
+ else {
|
|
+ $tb->ok( 0, "new() died" );
|
|
+ $tb->diag(" Error was: $error");
|
|
+ }
|
|
+
|
|
+ return $obj;
|
|
+}
|
|
|
|
=item B<pass>
|
|
|
|
@@ -593,12 +691,14 @@
|
|
|
|
sub pass (;$) {
|
|
my $tb = Test::More->builder;
|
|
- $tb->ok(1, @_);
|
|
+
|
|
+ return $tb->ok( 1, @_ );
|
|
}
|
|
|
|
sub fail (;$) {
|
|
my $tb = Test::More->builder;
|
|
- $tb->ok(0, @_);
|
|
+
|
|
+ return $tb->ok( 0, @_ );
|
|
}
|
|
|
|
=back
|
|
@@ -653,38 +753,40 @@
|
|
=cut
|
|
|
|
sub use_ok ($;@) {
|
|
- my($module, @imports) = @_;
|
|
+ my( $module, @imports ) = @_;
|
|
@imports = () unless @imports;
|
|
my $tb = Test::More->builder;
|
|
|
|
- my($pack,$filename,$line) = caller;
|
|
-
|
|
- local($@,$!,$SIG{__DIE__}); # isolate eval
|
|
+ my( $pack, $filename, $line ) = caller;
|
|
|
|
+ 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 $@;
|
|
+ unless($ok) {
|
|
+ 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
|
|
|
|
}
|
|
@@ -692,6 +794,24 @@
|
|
return $ok;
|
|
}
|
|
|
|
+sub _eval {
|
|
+ my( $code, @args ) = @_;
|
|
+
|
|
+ # Work around oddities surrounding resetting of $@ by immediately
|
|
+ # storing it.
|
|
+ my( $sigdie, $eval_result, $eval_error );
|
|
+ {
|
|
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
|
|
+ $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
+ $eval_error = $@;
|
|
+ $sigdie = $SIG{__DIE__} || undef;
|
|
+ }
|
|
+ # make sure that $code got a chance to set $SIG{__DIE__}
|
|
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
|
|
+
|
|
+ return( $eval_result, $eval_error );
|
|
+}
|
|
+
|
|
=item B<require_ok>
|
|
|
|
require_ok($module);
|
|
@@ -711,20 +831,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 $@;
|
|
+ unless($ok) {
|
|
+ chomp $eval_error;
|
|
$tb->diag(<<DIAGNOSTIC);
|
|
Tried to require '$module'.
|
|
- Error: $@
|
|
+ Error: $eval_error
|
|
DIAGNOSTIC
|
|
|
|
}
|
|
@@ -732,7 +852,6 @@
|
|
return $ok;
|
|
}
|
|
|
|
-
|
|
sub _is_module_name {
|
|
my $module = shift;
|
|
|
|
@@ -740,7 +859,8 @@
|
|
# End with an alphanumeric.
|
|
# The rest is an alphanumeric or ::
|
|
$module =~ s/\b::\b//g;
|
|
- $module =~ /^[a-zA-Z]\w*$/;
|
|
+
|
|
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
|
|
}
|
|
|
|
=back
|
|
@@ -769,59 +889,59 @@
|
|
references themselves (except for their type) are ignored. This means
|
|
aspects such as blessing and ties are not considered "different".
|
|
|
|
-is_deeply() current has very limited handling of function reference
|
|
+is_deeply() currently has very limited handling of function reference
|
|
and globs. It merely checks if they have the same referent. This may
|
|
improve in the future.
|
|
|
|
-Test::Differences and Test::Deep provide more in-depth functionality
|
|
+L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
|
|
along these lines.
|
|
|
|
=cut
|
|
|
|
-use vars qw(@Data_Stack %Refs_Seen);
|
|
+our( @Data_Stack, %Refs_Seen );
|
|
my $DNE = bless [], 'Does::Not::Exist';
|
|
|
|
sub _dne {
|
|
- ref $_[0] eq ref $DNE;
|
|
+ return ref $_[0] eq ref $DNE;
|
|
}
|
|
|
|
-
|
|
+## no critic (Subroutines::RequireArgUnpacking)
|
|
sub is_deeply {
|
|
my $tb = Test::More->builder;
|
|
|
|
unless( @_ == 2 or @_ == 3 ) {
|
|
- my $msg = <<WARNING;
|
|
+ my $msg = <<'WARNING';
|
|
is_deeply() takes two or three args, you gave %d.
|
|
This usually means you passed an array or hash instead
|
|
of a reference to it
|
|
WARNING
|
|
- chop $msg; # clip off newline so carp() will put in line/file
|
|
+ chop $msg; # clip off newline so carp() will put in line/file
|
|
|
|
_carp sprintf $msg, scalar @_;
|
|
|
|
- return $tb->ok(0);
|
|
+ return $tb->ok(0);
|
|
}
|
|
|
|
- my($got, $expected, $name) = @_;
|
|
+ my( $got, $expected, $name ) = @_;
|
|
|
|
- $tb->_unoverload_str(\$expected, \$got);
|
|
+ $tb->_unoverload_str( \$expected, \$got );
|
|
|
|
my $ok;
|
|
- if( !ref $got and !ref $expected ) { # neither is a reference
|
|
- $ok = $tb->is_eq($got, $expected, $name);
|
|
+ if( !ref $got and !ref $expected ) { # neither is a reference
|
|
+ $ok = $tb->is_eq( $got, $expected, $name );
|
|
}
|
|
- elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
|
|
- $ok = $tb->ok(0, $name);
|
|
- $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
|
|
+ elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
|
|
+ $ok = $tb->ok( 0, $name );
|
|
+ $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
|
|
}
|
|
- else { # both references
|
|
+ else { # both references
|
|
local @Data_Stack = ();
|
|
- if( _deep_check($got, $expected) ) {
|
|
- $ok = $tb->ok(1, $name);
|
|
+ if( _deep_check( $got, $expected ) ) {
|
|
+ $ok = $tb->ok( 1, $name );
|
|
}
|
|
else {
|
|
- $ok = $tb->ok(0, $name);
|
|
- $tb->diag(_format_stack(@Data_Stack));
|
|
+ $ok = $tb->ok( 0, $name );
|
|
+ $tb->diag( _format_stack(@Data_Stack) );
|
|
}
|
|
}
|
|
|
|
@@ -831,11 +951,11 @@
|
|
sub _format_stack {
|
|
my(@Stack) = @_;
|
|
|
|
- my $var = '$FOO';
|
|
+ my $var = '$FOO';
|
|
my $did_arrow = 0;
|
|
foreach my $entry (@Stack) {
|
|
my $type = $entry->{type} || '';
|
|
- my $idx = $entry->{'idx'};
|
|
+ my $idx = $entry->{'idx'};
|
|
if( $type eq 'HASH' ) {
|
|
$var .= "->" unless $did_arrow++;
|
|
$var .= "{$idx}";
|
|
@@ -849,18 +969,19 @@
|
|
}
|
|
}
|
|
|
|
- my @vals = @{$Stack[-1]{vals}}[0,1];
|
|
+ my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
|
|
my @vars = ();
|
|
- ($vars[0] = $var) =~ s/\$FOO/ \$got/;
|
|
- ($vars[1] = $var) =~ s/\$FOO/\$expected/;
|
|
+ ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
|
|
+ ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
|
|
|
|
my $out = "Structures begin differing at:\n";
|
|
- foreach my $idx (0..$#vals) {
|
|
+ foreach my $idx ( 0 .. $#vals ) {
|
|
my $val = $vals[$idx];
|
|
- $vals[$idx] = !defined $val ? 'undef' :
|
|
- _dne($val) ? "Does not exist" :
|
|
- ref $val ? "$val" :
|
|
- "'$val'";
|
|
+ $vals[$idx]
|
|
+ = !defined $val ? 'undef'
|
|
+ : _dne($val) ? "Does not exist"
|
|
+ : ref $val ? "$val"
|
|
+ : "'$val'";
|
|
}
|
|
|
|
$out .= "$vars[0] = $vals[0]\n";
|
|
@@ -870,14 +991,13 @@
|
|
return $out;
|
|
}
|
|
|
|
-
|
|
sub _type {
|
|
my $thing = shift;
|
|
|
|
return '' if !ref $thing;
|
|
|
|
for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
|
|
- return $type if UNIVERSAL::isa($thing, $type);
|
|
+ return $type if UNIVERSAL::isa( $thing, $type );
|
|
}
|
|
|
|
return '';
|
|
@@ -903,6 +1023,8 @@
|
|
test output. Like C<print> @diagnostic_message is simply concatenated
|
|
together.
|
|
|
|
+Returns false, so as to preserve failure.
|
|
+
|
|
Handy for this sort of thing:
|
|
|
|
ok( grep(/foo/, @users), "There's a foo user" ) or
|
|
@@ -922,14 +1044,49 @@
|
|
changing, but it is guaranteed that whatever you throw at it it won't
|
|
interfere with the test.
|
|
|
|
+=item B<note>
|
|
+
|
|
+ note(@diagnostic_message);
|
|
+
|
|
+Like diag(), except the message will not be seen when the test is run
|
|
+in a harness. It will only be visible in the verbose TAP stream.
|
|
+
|
|
+Handy for putting in notes which might be useful for debugging, but
|
|
+don't indicate a problem.
|
|
+
|
|
+ note("Tempfile is $tempfile");
|
|
+
|
|
=cut
|
|
|
|
sub diag {
|
|
- my $tb = Test::More->builder;
|
|
+ return Test::More->builder->diag(@_);
|
|
+}
|
|
|
|
- $tb->diag(@_);
|
|
+sub note {
|
|
+ return Test::More->builder->note(@_);
|
|
}
|
|
|
|
+=item B<explain>
|
|
+
|
|
+ my @dump = explain @diagnostic_message;
|
|
+
|
|
+Will dump the contents of any references in a human readable format.
|
|
+Usually you want to pass this into C<note> or C<diag>.
|
|
+
|
|
+Handy for things like...
|
|
+
|
|
+ is_deeply($have, $want) || diag explain $have;
|
|
+
|
|
+or
|
|
+
|
|
+ note explain \%args;
|
|
+ Some::Class->method(%args);
|
|
+
|
|
+=cut
|
|
+
|
|
+sub explain {
|
|
+ return Test::More->builder->explain(@_);
|
|
+}
|
|
|
|
=back
|
|
|
|
@@ -993,9 +1150,9 @@
|
|
|
|
=cut
|
|
|
|
-#'#
|
|
+## no critic (Subroutines::RequireFinalReturn)
|
|
sub skip {
|
|
- my($why, $how_many) = @_;
|
|
+ my( $why, $how_many ) = @_;
|
|
my $tb = Test::More->builder;
|
|
|
|
unless( defined $how_many ) {
|
|
@@ -1006,19 +1163,19 @@
|
|
}
|
|
|
|
if( defined $how_many and $how_many =~ /\D/ ) {
|
|
- _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
|
|
+ _carp
|
|
+ "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
|
|
$how_many = 1;
|
|
}
|
|
|
|
- for( 1..$how_many ) {
|
|
+ for( 1 .. $how_many ) {
|
|
$tb->skip($why);
|
|
}
|
|
|
|
- local $^W = 0;
|
|
+ no warnings 'exiting';
|
|
last SKIP;
|
|
}
|
|
|
|
-
|
|
=item B<TODO: BLOCK>
|
|
|
|
TODO: {
|
|
@@ -1081,7 +1238,7 @@
|
|
=cut
|
|
|
|
sub todo_skip {
|
|
- my($why, $how_many) = @_;
|
|
+ my( $why, $how_many ) = @_;
|
|
my $tb = Test::More->builder;
|
|
|
|
unless( defined $how_many ) {
|
|
@@ -1091,11 +1248,11 @@
|
|
$how_many = 1;
|
|
}
|
|
|
|
- for( 1..$how_many ) {
|
|
+ for( 1 .. $how_many ) {
|
|
$tb->todo_skip($why);
|
|
}
|
|
|
|
- local $^W = 0;
|
|
+ no warnings 'exiting';
|
|
last TODO;
|
|
}
|
|
|
|
@@ -1131,11 +1288,13 @@
|
|
|
|
The test will exit with 255.
|
|
|
|
+For even better control look at L<Test::Most>.
|
|
+
|
|
=cut
|
|
|
|
sub BAIL_OUT {
|
|
my $reason = shift;
|
|
- my $tb = Test::More->builder;
|
|
+ my $tb = Test::More->builder;
|
|
|
|
$tb->BAIL_OUT($reason);
|
|
}
|
|
@@ -1174,14 +1333,14 @@
|
|
|
|
#'#
|
|
sub eq_array {
|
|
- local @Data_Stack;
|
|
+ local @Data_Stack = ();
|
|
_deep_check(@_);
|
|
}
|
|
|
|
-sub _eq_array {
|
|
- my($a1, $a2) = @_;
|
|
+sub _eq_array {
|
|
+ my( $a1, $a2 ) = @_;
|
|
|
|
- if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
|
|
+ if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
|
|
warn "eq_array passed a non-array ref";
|
|
return 0;
|
|
}
|
|
@@ -1190,12 +1349,12 @@
|
|
|
|
my $ok = 1;
|
|
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
|
|
- for (0..$max) {
|
|
+ for( 0 .. $max ) {
|
|
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
|
|
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
|
|
|
|
- push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
|
|
- $ok = _deep_check($e1,$e2);
|
|
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
|
|
+ $ok = _deep_check( $e1, $e2 );
|
|
pop @Data_Stack if $ok;
|
|
|
|
last unless $ok;
|
|
@@ -1205,7 +1364,7 @@
|
|
}
|
|
|
|
sub _deep_check {
|
|
- my($e1, $e2) = @_;
|
|
+ my( $e1, $e2 ) = @_;
|
|
my $tb = Test::More->builder;
|
|
|
|
my $ok = 0;
|
|
@@ -1217,27 +1376,31 @@
|
|
|
|
{
|
|
# Quiet uninitialized value warnings when comparing undefs.
|
|
- local $^W = 0;
|
|
+ no warnings 'uninitialized';
|
|
|
|
- $tb->_unoverload_str(\$e1, \$e2);
|
|
+ $tb->_unoverload_str( \$e1, \$e2 );
|
|
|
|
# Either they're both references or both not.
|
|
- my $same_ref = !(!ref $e1 xor !ref $e2);
|
|
- my $not_ref = (!ref $e1 and !ref $e2);
|
|
+ my $same_ref = !( !ref $e1 xor !ref $e2 );
|
|
+ my $not_ref = ( !ref $e1 and !ref $e2 );
|
|
|
|
if( defined $e1 xor defined $e2 ) {
|
|
$ok = 0;
|
|
}
|
|
- elsif ( _dne($e1) xor _dne($e2) ) {
|
|
+ elsif( !defined $e1 and !defined $e2 ) {
|
|
+ # Shortcut if they're both defined.
|
|
+ $ok = 1;
|
|
+ }
|
|
+ elsif( _dne($e1) xor _dne($e2) ) {
|
|
$ok = 0;
|
|
}
|
|
- elsif ( $same_ref and ($e1 eq $e2) ) {
|
|
+ elsif( $same_ref and( $e1 eq $e2 ) ) {
|
|
$ok = 1;
|
|
}
|
|
- elsif ( $not_ref ) {
|
|
- push @Data_Stack, { type => '', vals => [$e1, $e2] };
|
|
- $ok = 0;
|
|
- }
|
|
+ elsif($not_ref) {
|
|
+ push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
|
|
+ $ok = 0;
|
|
+ }
|
|
else {
|
|
if( $Refs_Seen{$e1} ) {
|
|
return $Refs_Seen{$e1} eq $e2;
|
|
@@ -1250,50 +1413,48 @@
|
|
$type = 'DIFFERENT' unless _type($e2) eq $type;
|
|
|
|
if( $type eq 'DIFFERENT' ) {
|
|
- push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
|
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
|
|
$ok = 0;
|
|
}
|
|
elsif( $type eq 'ARRAY' ) {
|
|
- $ok = _eq_array($e1, $e2);
|
|
+ $ok = _eq_array( $e1, $e2 );
|
|
}
|
|
elsif( $type eq 'HASH' ) {
|
|
- $ok = _eq_hash($e1, $e2);
|
|
+ $ok = _eq_hash( $e1, $e2 );
|
|
}
|
|
elsif( $type eq 'REF' ) {
|
|
- push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
|
- $ok = _deep_check($$e1, $$e2);
|
|
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
|
|
+ $ok = _deep_check( $$e1, $$e2 );
|
|
pop @Data_Stack if $ok;
|
|
}
|
|
elsif( $type eq 'SCALAR' ) {
|
|
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
|
|
- $ok = _deep_check($$e1, $$e2);
|
|
+ push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
|
|
+ $ok = _deep_check( $$e1, $$e2 );
|
|
pop @Data_Stack if $ok;
|
|
}
|
|
- elsif( $type ) {
|
|
- push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
|
+ elsif($type) {
|
|
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
|
|
$ok = 0;
|
|
}
|
|
- else {
|
|
- _whoa(1, "No type in _deep_check");
|
|
- }
|
|
+ else {
|
|
+ _whoa( 1, "No type in _deep_check" );
|
|
+ }
|
|
}
|
|
}
|
|
|
|
return $ok;
|
|
}
|
|
|
|
-
|
|
sub _whoa {
|
|
- my($check, $desc) = @_;
|
|
- if( $check ) {
|
|
- die <<WHOA;
|
|
+ my( $check, $desc ) = @_;
|
|
+ if($check) {
|
|
+ die <<"WHOA";
|
|
WHOA! $desc
|
|
This should never happen! Please contact the author immediately!
|
|
WHOA
|
|
}
|
|
}
|
|
|
|
-
|
|
=item B<eq_hash>
|
|
|
|
my $is_eq = eq_hash(\%got, \%expected);
|
|
@@ -1304,14 +1465,14 @@
|
|
=cut
|
|
|
|
sub eq_hash {
|
|
- local @Data_Stack;
|
|
+ local @Data_Stack = ();
|
|
return _deep_check(@_);
|
|
}
|
|
|
|
sub _eq_hash {
|
|
- my($a1, $a2) = @_;
|
|
+ my( $a1, $a2 ) = @_;
|
|
|
|
- if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
|
|
+ if( grep _type($_) ne 'HASH', $a1, $a2 ) {
|
|
warn "eq_hash passed a non-hash ref";
|
|
return 0;
|
|
}
|
|
@@ -1320,12 +1481,12 @@
|
|
|
|
my $ok = 1;
|
|
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
|
|
- foreach my $k (keys %$bigger) {
|
|
+ foreach my $k ( keys %$bigger ) {
|
|
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
|
|
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
|
|
|
|
- push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
|
|
- $ok = _deep_check($e1, $e2);
|
|
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
|
|
+ $ok = _deep_check( $e1, $e2 );
|
|
pop @Data_Stack if $ok;
|
|
|
|
last unless $ok;
|
|
@@ -1356,18 +1517,17 @@
|
|
|
|
eq_set([\1, \2], [\2, \1]);
|
|
|
|
-Test::Deep contains much better set comparison functions.
|
|
+L<Test::Deep> contains much better set comparison functions.
|
|
|
|
=cut
|
|
|
|
-sub eq_set {
|
|
- my($a1, $a2) = @_;
|
|
+sub eq_set {
|
|
+ my( $a1, $a2 ) = @_;
|
|
return 0 unless @$a1 == @$a2;
|
|
|
|
- # There's faster ways to do this, but this is easiest.
|
|
- local $^W = 0;
|
|
+ no warnings 'uninitialized';
|
|
|
|
- # It really doesn't matter how we sort them, as long as both arrays are
|
|
+ # It really doesn't matter how we sort them, as long as both arrays are
|
|
# sorted with the same algorithm.
|
|
#
|
|
# Ensure that references are not accidentally treated the same as a
|
|
@@ -1379,8 +1539,8 @@
|
|
# I don't know how references would be sorted so we just don't sort
|
|
# them. This means eq_set doesn't really work with refs.
|
|
return eq_array(
|
|
- [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
|
|
- [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
|
|
+ [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
|
|
+ [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
|
|
);
|
|
}
|
|
|
|
@@ -1438,7 +1598,25 @@
|
|
|
|
=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 utf8 / "Wide character in print"
|
|
+
|
|
+If you use utf8 or other non-ASCII characters with Test::More you
|
|
+might get a "Wide character in print" warning. Using C<binmode
|
|
+STDOUT, ":utf8"> will not fix it. Test::Builder (which powers
|
|
+Test::More) duplicates STDOUT and STDERR. So any changes to them,
|
|
+including changing their output disciplines, will not be seem by
|
|
+Test::More.
|
|
+
|
|
+The work around is to change the filehandles used by Test::Builder
|
|
+directly.
|
|
+
|
|
+ my $builder = Test::More->builder;
|
|
+ binmode $builder->output, ":utf8";
|
|
+ binmode $builder->failure_output, ":utf8";
|
|
+ binmode $builder->todo_output, ":utf8";
|
|
|
|
|
|
=item Overloaded objects
|
|
@@ -1452,7 +1630,7 @@
|
|
|
|
However, it does mean that functions like is_deeply() cannot be used to
|
|
test the internals of string overloaded objects. In this case I would
|
|
-suggest Test::Deep which contains more flexible testing functions for
|
|
+suggest L<Test::Deep> which contains more flexible testing functions for
|
|
complex data structures.
|
|
|
|
|
|
@@ -1474,11 +1652,11 @@
|
|
|
|
=item Test::Harness upgrade
|
|
|
|
-no_plan and todo depend on new Test::Harness features and fixes. If
|
|
-you're going to distribute tests that use no_plan or todo your
|
|
-end-users will have to upgrade Test::Harness to the latest one on
|
|
-CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
|
|
-will work fine.
|
|
+no_plan, todo and done_testing() depend on new Test::Harness features
|
|
+and fixes. If you're going to distribute tests that use no_plan or
|
|
+todo your end-users will have to upgrade Test::Harness to the latest
|
|
+one on CPAN. If you avoid no_plan and TODO tests, the stock
|
|
+Test::Harness will work fine.
|
|
|
|
Installing Test::More should also upgrade Test::Harness.
|
|
|
|
@@ -1506,21 +1684,21 @@
|
|
some tests. You can upgrade to Test::More later (it's forward
|
|
compatible).
|
|
|
|
-L<Test> is the old testing module. Its main benefit is that it has
|
|
-been distributed with Perl since 5.004_05.
|
|
-
|
|
-L<Test::Harness> for details on how your test results are interpreted
|
|
-by Perl.
|
|
+L<Test::Harness> is the test runner and output interpreter for Perl.
|
|
+It's the thing that powers C<make test> and where the C<prove> utility
|
|
+comes from.
|
|
+
|
|
+L<Test::Legacy> tests written with Test.pm, the original testing
|
|
+module, do not play well with other testing libraries. Test::Legacy
|
|
+emulates the Test.pm interface and does play well with others.
|
|
|
|
L<Test::Differences> for more ways to test complex data structures.
|
|
And it plays well with Test::More.
|
|
|
|
-L<Test::Class> is like XUnit but more perlish.
|
|
+L<Test::Class> is like xUnit but more perlish.
|
|
|
|
L<Test::Deep> gives you more powerful complex data structure testing.
|
|
|
|
-L<Test::Unit> is XUnit style testing.
|
|
-
|
|
L<Test::Inline> shows the idea of embedded testing.
|
|
|
|
L<Bundle::Test> installs a whole bunch of useful test modules.
|
|
@@ -1539,9 +1717,15 @@
|
|
See F<http://rt.cpan.org> to report and view bugs.
|
|
|
|
|
|
+=head1 SOURCE
|
|
+
|
|
+The source code repository for Test::More can be found at
|
|
+F<http://github.com/schwern/test-more/>.
|
|
+
|
|
+
|
|
=head1 COPYRIGHT
|
|
|
|
-Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
|
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/Changes perl-5.10.0/lib/Test/Simple/Changes
|
|
--- perl-5.10.0.orig/lib/Test/Simple/Changes 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/Changes 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,8 +1,226 @@
|
|
+0.92 Fri Jul 3 11:08:56 PDT 2009
|
|
+ Test Fixes
|
|
+ * Silence noise on VMS in exit.t (Craig Berry)
|
|
+ * Skip Builder/fork_with_new_stdout.t on systems without fork (Craig Berry)
|
|
+
|
|
+
|
|
+0.90 Thu Jul 2 13:18:25 PDT 2009
|
|
+ Docs
|
|
+ * Finally added a note about the "Wide character in print" warning and
|
|
+ how to work around it.
|
|
+ * Note the IO::Stringy license in our copy of it.
|
|
+ [test-more.googlecode.com 47]
|
|
+
|
|
+ Test Fixes
|
|
+ * Small fixes for integration with the Perl core
|
|
+ [bleadperl eaa0815147e13cd4ab5b3d6ca8f26544a9f0c3b4]
|
|
+ * exit code tests could be effected by errno when PERLIO=stdio
|
|
+ [bleadperl c76230386fc5e6fba9fdbeab473abbf4f4adcbe3]
|
|
+
|
|
+ Other
|
|
+ * This is a stable release for 5.10.1. It does not include
|
|
+ the subtest() work in 0.89_01.
|
|
+
|
|
+
|
|
+0.88 Sat May 30 12:31:24 PDT 2009
|
|
+ Turing 0.87_03 into a stable release.
|
|
+
|
|
+
|
|
+0.87_03 Sun May 24 13:41:40 PDT 2009
|
|
+ New Features
|
|
+ * isa_ok() now works on classes. (Peter Scott)
|
|
+
|
|
+
|
|
+0.87_02 Sat Apr 11 12:54:14 PDT 2009
|
|
+ Test Fixes
|
|
+ * Some filesystems don't like it when you open a file for writing multiple
|
|
+ times. Fixes t/Builder/reset.t. [rt.cpan.org 17298]
|
|
+ * Check how an operating system is going to map exit codes. Some OS'
|
|
+ will map them... sometimes. [rt.cpan.org 42148]
|
|
+ * Fix Test::Builder::NoOutput on 5.6.2.
|
|
+
|
|
+
|
|
+0.87_01 Sun Mar 29 09:56:52 BST 2009
|
|
+ New Features
|
|
+ * done_testing() allows you to declare that you have finished running tests,
|
|
+ and how many you ran. It is a safer no_plan and effectively replaces it.
|
|
+ * output() now supports scalar references.
|
|
+
|
|
+ Feature Changes
|
|
+ * You can now run a test without first declaring a plan. This allows
|
|
+ done_testing() to work.
|
|
+ * You can now call current_test() without first declaring a plan.
|
|
+
|
|
+ Bug Fixes
|
|
+ * skip_all() with no reason would output "1..0" which is invalid TAP. It will
|
|
+ now always include the SKIP directive.
|
|
+
|
|
+ Other
|
|
+ * Repository moved to github.
|
|
+
|
|
+
|
|
+0.86 Sun Nov 9 01:09:05 PST 2008
|
|
+ Same as 0.85_01
|
|
+
|
|
+
|
|
+0.85_01 Thu Oct 23 18:57:38 PDT 2008
|
|
+ New Features
|
|
+ * cmp_ok() now displays the error if the comparison throws one.
|
|
+ For example, broken overloaded objects.
|
|
+
|
|
+ Bug Fixes
|
|
+ * cmp_ok() no longer stringifies or numifies its arguments before comparing.
|
|
+ This makes cmp_ok() properly test overloaded ops.
|
|
+ [rt.cpan.org 24186] [code.google.com 16]
|
|
+ * diag() properly escapes blank lines.
|
|
+
|
|
+ Feature Changes
|
|
+ * cmp_ok() now reports warnings and errors as coming from inside cmp_ok,
|
|
+ as well as reporting the caller's file and line. This let's the user
|
|
+ know where cmp_ok() was called from while reminding them that it is
|
|
+ being run in a different context.
|
|
+
|
|
+ Other
|
|
+ * Dependency on ExtUtils::MakeMaker 6.27 only on Windows otherwise the
|
|
+ nested tests won't run.
|
|
+
|
|
+
|
|
+0.84 Wed Oct 15 09:06:12 EDT 2008
|
|
+ Other
|
|
+ * 0.82 accidentally shipped with experimental Mouse dependency.
|
|
+
|
|
+
|
|
+0.82 Tue Oct 14 23:06:56 EDT 2008
|
|
+ Bug Fixes
|
|
+ - 0.81_01 broke $TODO such that $TODO = '' was considered todo.
|
|
+
|
|
+
|
|
+0.81_02 Tue Sep 9 04:35:40 PDT 2008
|
|
+ New Features
|
|
+ * Test::Builder->reset_outputs() to reset all the output methods back to
|
|
+ their defaults.
|
|
+
|
|
+ Bug Fixes
|
|
+ - Fixed the file and line number reported by like when it gets a bad
|
|
+ regex.
|
|
+
|
|
+ Features Changed
|
|
+ - Now preserves the tests' exit code if it exits abnormally, rather than
|
|
+ setting it to 255.
|
|
+ - Changed the "Looks like your test died" message to
|
|
+ "Looks like your test exited with $exit_code"
|
|
+ - no_plan now only warns if given an argument. There were a lot of people
|
|
+ doing that, and it's a sensible mistake. [test-more.googlecode.com 13]
|
|
+
|
|
+
|
|
+0.81_01 Sat Sep 6 15:13:50 PDT 2008
|
|
+ New Features
|
|
+ * Adam Kennedy bribed me to add new_ok(). The price was one DEFCON license key.
|
|
+ [rt.cpan.org 8891]
|
|
+ * TODO tests can now start and end with 'todo_start' and 'todo_end'
|
|
+ Test::Builder methods. [rt.cpan.org 38018]
|
|
+ * Added Test::Builder->in_todo() for a safe way to check if a test is inside a
|
|
+ TODO block. This allows TODO tests with no reason.
|
|
+ * Added note() and explain() to both Test::More and Test::Builder.
|
|
+ [rt.cpan.org 14764] [test-more.googlecode.com 3]
|
|
+
|
|
+ Features Changed
|
|
+ * Changed the message for extra tests run to show the number of tests run rather than
|
|
+ the number extra to avoid the user having to do mental math.
|
|
+ [rt.cpan.org 7022]
|
|
+
|
|
+ Bug fixes
|
|
+ - using a relative path to perl broke tests [rt.cpan.org 34050]
|
|
+ - use_ok() broke $SIG{__DIE__} in the used module [rt.cpan.org 34065]
|
|
+ - diagnostics for isnt() were confusing on failure [rt.cpan.org 33642]
|
|
+ - warnings when MakeMaker's version contained _ [rt.cpan.org 33626]
|
|
+ - add explicit test that non-integer plans die correctly [rt.cpan.org 28836]
|
|
+ (Thanks to Hans Dieter Pearcey [confound] for fixing the above)
|
|
+ - die if no_plan is given an argument [rt.cpan.org 27429]
|
|
+
|
|
+
|
|
+0.80 Sun Apr 6 17:25:01 CEST 2008
|
|
+ Test fixes
|
|
+ - Completely disable the utf8 test. It was causing perl to panic on some OS's.
|
|
+
|
|
+
|
|
+0.79_01 Wed Feb 27 03:04:54 PST 2008
|
|
+ Bug fixes
|
|
+ - Let's try the IO layer copying again, this time with the test
|
|
+ fixed for 5.10.
|
|
+
|
|
+
|
|
+0.78 Wed Feb 27 01:59:09 PST 2008
|
|
+ Bug fixes
|
|
+ * Whoops, the version of Test::Builder::Tester got moved backwards.
|
|
+
|
|
+
|
|
+0.77 Wed Feb 27 01:55:55 PST 2008
|
|
+ Bug fixes
|
|
+ - "use Test::Builder::Module" no longer sets exported_to() or does
|
|
+ any other importing.
|
|
+ - Fix the $TODO finding code so it can find $TODO without the benefit
|
|
+ of exported_to(), which is often wrong.
|
|
+ - Turn off the filehandle locale stuff for the moment, there's a
|
|
+ problem on 5.10. We'll try it again next release.
|
|
+
|
|
+ Doc improvements
|
|
+ - Improve the Test::Builder SYNOPSIS to use Test::Builder::Module
|
|
+ rather than write it's own import().
|
|
+
|
|
+
|
|
+0.76_02 Sun Feb 24 13:12:55 PST 2008
|
|
+ Bug fixes
|
|
+ * The default test output filehandles will NOT use utf8.
|
|
+ They will now copy the IO layers from STDOUT and STDERR.
|
|
+ This means if :utf8 is on then it will honor it and not
|
|
+ warn about wide characters.
|
|
+
|
|
+
|
|
+0.76_01 Sat Feb 23 20:44:32 PST 2008
|
|
+ Bug fixes
|
|
+ * Test::Builder no longer uses a __DIE__ handler. This resolves a number
|
|
+ of problems with exit codes being swallowed or other module's handlers
|
|
+ being interfered with. [rt.cpan.org 25294]
|
|
+ - Allow maybe_regex() to detect blessed regexes. [bleadperl @32880]
|
|
+ - The default test output filehandles will now use utf8.
|
|
+ [rt.cpan.org 21091]
|
|
+
|
|
+ Test fixes
|
|
+ - Remove the signature test. Adds no security and just generates
|
|
+ failures.
|
|
+
|
|
+
|
|
+0.75 Sat Feb 23 19:03:38 PST 2008
|
|
+ Incompatibilities
|
|
+ * The minimum version is now 5.6.0.
|
|
+
|
|
+ Bug fixes
|
|
+ - Turns out require_ok() had the same bug as use_ok() in a BEGIN block.
|
|
+ - ok() was not honoring exported_to() when looking for $TODO as it
|
|
+ should be.
|
|
+
|
|
+ Test fixes
|
|
+ * is_deeply_with_threads.t will not run unless AUTHOR_TESTING is set.
|
|
+ This is because it tickles intermittent threading bugs in many perls
|
|
+ and causes a lot of bug reports about which I can do nothing.
|
|
+
|
|
+ Misc
|
|
+ - Ran through perlcritic and did some cleaning.
|
|
+
|
|
+0.74 Thu Nov 29 15:39:57 PST 2007
|
|
+ Misc
|
|
+ - Add abstract and author to the meta information.
|
|
+
|
|
+0.73_01 Mon Oct 15 20:35:15 EDT 2007
|
|
+ Bug fixes
|
|
+ * Put the use_ok() fix from 0.71 back.
|
|
+
|
|
0.72 Wed Sep 19 20:08:07 PDT 2007
|
|
Bug unfixes
|
|
* The BEGIN { use_ok } fix for [rt.cpan.org 28345] revealed a small pile of
|
|
- mistakes in CPAN module test suites. Rolling the fix back to give the authors
|
|
- a bit of time to fix their tests.
|
|
+ mistakes in CPAN module test suites. Rolling the fix back to give the
|
|
+ authors a bit of time to fix their tests.
|
|
|
|
0.71 Thu Sep 13 20:42:36 PDT 2007
|
|
Bug fixes
|
|
@@ -15,8 +233,8 @@
|
|
- Removed dependency on Text::Soundex [rt.cpan.org 25022]
|
|
- Fixed a 5.5.x failure in fail-more.t
|
|
* Got rid of the annoying sort_bug.t test that revealed problems with some
|
|
- threaded perls. It was testing the deprecated eq_* functions and not worth the
|
|
- bother. Now it tests is_deeply(). [rt.cpan.org 17791]
|
|
+ threaded perls. It was testing the deprecated eq_* functions and not
|
|
+ worth the bother. Now it tests is_deeply(). [rt.cpan.org 17791]
|
|
|
|
Doc fixes
|
|
- Minor POD mistake in Test::Builder [rt.cpan.org 28869]
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/README perl-5.10.0/lib/Test/Simple/README
|
|
--- perl-5.10.0.orig/lib/Test/Simple/README 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/README 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -13,3 +13,10 @@
|
|
make
|
|
make test
|
|
make install
|
|
+
|
|
+It requires Perl version 5.6.0 or newer and Test::Harness 2.03 or newer.
|
|
+
|
|
+
|
|
+* More Info
|
|
+
|
|
+More information can be found at http://test-more.googlecode.com/
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/bad_plan.t perl-5.10.0/lib/Test/Simple/t/bad_plan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/bad_plan.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/bad_plan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -7,32 +7,17 @@
|
|
}
|
|
}
|
|
|
|
-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;
|
|
-}
|
|
-
|
|
-
|
|
use Test::Builder;
|
|
my $Test = Test::Builder->new;
|
|
+$Test->plan( tests => 2 );
|
|
+$Test->level(0);
|
|
|
|
-print "1..2\n";
|
|
+my $tb = Test::Builder->create;
|
|
|
|
-eval { $Test->plan(7); };
|
|
-ok( $@ =~ /^plan\(\) doesn't understand 7/, 'bad plan()' ) ||
|
|
+eval { $tb->plan(7); };
|
|
+$Test->like( $@, qr/^plan\(\) doesn't understand 7/, 'bad plan()' ) ||
|
|
print STDERR "# $@";
|
|
|
|
-eval { $Test->plan(wibble => 7); };
|
|
-ok( $@ =~ /^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) ||
|
|
+eval { $tb->plan(wibble => 7); };
|
|
+$Test->like( $@, qr/^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) ||
|
|
print STDERR "# $@";
|
|
-
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/bail_out.t perl-5.10.0/lib/Test/Simple/t/bail_out.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/bail_out.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/bail_out.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -18,30 +18,22 @@
|
|
|
|
use Test::Builder;
|
|
use Test::More;
|
|
-use TieOut;
|
|
|
|
-my $output = tie *FAKEOUT, 'TieOut';
|
|
+my $output;
|
|
my $TB = Test::More->builder;
|
|
-$TB->output(\*FAKEOUT);
|
|
+$TB->output(\$output);
|
|
|
|
my $Test = Test::Builder->create;
|
|
$Test->level(0);
|
|
|
|
-if( $] >= 5.005 ) {
|
|
- $Test->plan(tests => 3);
|
|
-}
|
|
-else {
|
|
- $Test->plan(skip_all =>
|
|
- 'CORE::GLOBAL::exit, introduced in 5.005, is needed for testing');
|
|
-}
|
|
-
|
|
+$Test->plan(tests => 3);
|
|
|
|
plan tests => 4;
|
|
|
|
BAIL_OUT("ROCKS FALL! EVERYONE DIES!");
|
|
|
|
|
|
-$Test->is_eq( $output->read, <<'OUT' );
|
|
+$Test->is_eq( $output, <<'OUT' );
|
|
1..4
|
|
Bail out! ROCKS FALL! EVERYONE DIES!
|
|
OUT
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_require_ok.t perl-5.10.0/lib/Test/Simple/t/BEGIN_require_ok.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_require_ok.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/BEGIN_require_ok.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,27 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+# Fixed a problem with BEGIN { use_ok or require_ok } silently failing when there's no
|
|
+# plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak.
|
|
+
|
|
+use strict;
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = ('../lib', 'lib');
|
|
+ }
|
|
+ else {
|
|
+ unshift @INC, 't/lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+use Test::More;
|
|
+
|
|
+my $result;
|
|
+BEGIN {
|
|
+ $result = require_ok("strict");
|
|
+}
|
|
+
|
|
+ok $result, "require_ok ran";
|
|
+
|
|
+done_testing(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_use_ok.t perl-5.10.0/lib/Test/Simple/t/BEGIN_use_ok.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_use_ok.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/BEGIN_use_ok.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,26 @@
|
|
+#!/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 {
|
|
+ $result = use_ok("strict");
|
|
+}
|
|
+
|
|
+ok( $result, "use_ok() ran" );
|
|
+done_testing(2);
|
|
+
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/c_flag.t perl-5.10.0/lib/Test/Simple/t/c_flag.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/c_flag.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/c_flag.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,21 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+# Test::More should not print anything when Perl is only doing
|
|
+# a compile as with the -c flag or B::Deparse or perlcc.
|
|
+
|
|
+# HARNESS_ACTIVE=1 was causing an error with -c
|
|
+{
|
|
+ local $ENV{HARNESS_ACTIVE} = 1;
|
|
+ local $^C = 1;
|
|
+
|
|
+ require Test::More;
|
|
+ Test::More->import(tests => 1);
|
|
+
|
|
+ fail("This should not show up");
|
|
+}
|
|
+
|
|
+Test::More->builder->no_ending(1);
|
|
+
|
|
+print "1..1\n";
|
|
+print "ok 1\n";
|
|
+
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/cmp_ok.t perl-5.10.0/lib/Test/Simple/t/cmp_ok.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/cmp_ok.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/cmp_ok.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -3,7 +3,7 @@
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
- @INC = ('../lib', 'lib');
|
|
+ @INC = ('../lib', 'lib', '../lib/Test/Simple/t/lib');
|
|
}
|
|
else {
|
|
unshift @INC, 't/lib';
|
|
@@ -29,19 +29,19 @@
|
|
$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 $ok = cmp_ok($left, $cmp, $right, "cmp_ok");
|
|
+ $TB->is_num(!!$ok, !!$expect{ok}, " right return");
|
|
|
|
my $diag = $err->read;
|
|
if( !$ok and $expect{error} ) {
|
|
$diag =~ s/^# //mg;
|
|
- $TB->like( $diag, "/\Q$expect{error}\E/" );
|
|
+ $TB->like( $diag, qr/\Q$expect{error}\E/, " expected error" );
|
|
}
|
|
elsif( $ok ) {
|
|
- $TB->is_eq( $diag, '' );
|
|
+ $TB->is_eq( $diag, '', " passed without diagnostic" );
|
|
}
|
|
else {
|
|
- $TB->ok(1);
|
|
+ $TB->ok(1, " failed without diagnostic");
|
|
}
|
|
}
|
|
|
|
@@ -49,6 +49,10 @@
|
|
use Test::More;
|
|
Test::More->builder->no_ending(1);
|
|
|
|
+require MyOverload;
|
|
+my $cmp = Overloaded::Compare->new("foo", 42);
|
|
+my $ify = Overloaded::Ify->new("bar", 23);
|
|
+
|
|
my @Tests = (
|
|
[1, '==', 1],
|
|
[1, '==', 2],
|
|
@@ -56,23 +60,12 @@
|
|
["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],
|
|
- );
|
|
-}
|
|
+ [$cmp, '==', 42],
|
|
+ [$cmp, 'eq', "foo"],
|
|
+ [$ify, 'eq', "bar"],
|
|
+ [$ify, "==", 23],
|
|
+);
|
|
|
|
plan tests => scalar @Tests;
|
|
$TB->plan(tests => @Tests * 2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/create.t perl-5.10.0/lib/Test/Simple/t/create.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/create.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/create.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -12,8 +12,9 @@
|
|
}
|
|
}
|
|
|
|
-use Test::More tests => 8;
|
|
+use Test::More tests => 7;
|
|
use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
|
|
my $more_tb = Test::More->builder;
|
|
isa_ok $more_tb, 'Test::Builder';
|
|
@@ -22,24 +23,18 @@
|
|
is $more_tb, Test::Builder->new, ' does not interfere with ->new';
|
|
|
|
{
|
|
- my $new_tb = Test::Builder->create;
|
|
+ my $new_tb = Test::Builder::NoOutput->create;
|
|
|
|
isa_ok $new_tb, 'Test::Builder';
|
|
isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object';
|
|
|
|
- $new_tb->output("some_file");
|
|
- END { 1 while unlink "some_file" }
|
|
-
|
|
$new_tb->plan(tests => 1);
|
|
- $new_tb->ok(1);
|
|
-}
|
|
-
|
|
-pass("Changing output() of new TB doesn't interfere with singleton");
|
|
+ $new_tb->ok(1, "a test");
|
|
|
|
-ok open FILE, "some_file";
|
|
-is join("", <FILE>), <<OUT;
|
|
+ is $new_tb->read, <<'OUT';
|
|
1..1
|
|
-ok 1
|
|
+ok 1 - a test
|
|
OUT
|
|
+}
|
|
|
|
-close FILE;
|
|
+pass("Changing output() of new TB doesn't interfere with singleton");
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/current_test.t perl-5.10.0/lib/Test/Simple/t/current_test.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/current_test.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/current_test.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,11 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+# Dave Rolsky found a bug where if current_test() is used and no
|
|
+# tests are run via Test::Builder it will blow up.
|
|
+
|
|
+use Test::Builder;
|
|
+$TB = Test::Builder->new;
|
|
+$TB->plan(tests => 2);
|
|
+print "ok 1\n";
|
|
+print "ok 2\n";
|
|
+$TB->current_test(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/current_test_without_plan.t perl-5.10.0/lib/Test/Simple/t/current_test_without_plan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/current_test_without_plan.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/current_test_without_plan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,16 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+# Test that current_test() will work without a declared plan.
|
|
+
|
|
+use Test::Builder;
|
|
+
|
|
+my $tb = Test::Builder->new;
|
|
+$tb->current_test(2);
|
|
+print <<'END';
|
|
+ok 1
|
|
+ok 2
|
|
+END
|
|
+
|
|
+$tb->ok(1, "Third test");
|
|
+
|
|
+$tb->done_testing(3);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/curr_test.t perl-5.10.0/lib/Test/Simple/t/curr_test.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/curr_test.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/curr_test.t 1970-01-01 01:00:00.000000000 +0100
|
|
@@ -1,11 +0,0 @@
|
|
-#!/usr/bin/perl -w
|
|
-
|
|
-# Dave Rolsky found a bug where if current_test() is used and no
|
|
-# tests are run via Test::Builder it will blow up.
|
|
-
|
|
-use Test::Builder;
|
|
-$TB = Test::Builder->new;
|
|
-$TB->plan(tests => 2);
|
|
-print "ok 1\n";
|
|
-print "ok 2\n";
|
|
-$TB->current_test(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/details.t perl-5.10.0/lib/Test/Simple/t/details.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/details.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/details.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -29,13 +29,11 @@
|
|
|
|
# Inline TODO tests will confuse pre 1.20 Test::Harness, so we
|
|
# should just avoid the problem and not print it out.
|
|
-my $out_fh = $Test->output;
|
|
-my $todo_fh = $Test->todo_output;
|
|
my $start_test = $Test->current_test + 1;
|
|
-require TieOut;
|
|
-tie *FH, 'TieOut';
|
|
-$Test->output(\*FH);
|
|
-$Test->todo_output(\*FH);
|
|
+
|
|
+my $output = '';
|
|
+$Test->output(\$output);
|
|
+$Test->todo_output(\$output);
|
|
|
|
SKIP: {
|
|
$Test->skip( 'just testing skip' );
|
|
@@ -68,8 +66,7 @@
|
|
};
|
|
|
|
for ($start_test..$Test->current_test) { print "ok $_\n" }
|
|
-$Test->output($out_fh);
|
|
-$Test->todo_output($todo_fh);
|
|
+$Test->reset_outputs;
|
|
|
|
$Test->is_num( scalar $Test->summary(), 4, 'summary' );
|
|
push @Expected_Details, { 'ok' => 1,
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/diag.t perl-5.10.0/lib/Test/Simple/t/diag.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/diag.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/diag.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -24,49 +24,58 @@
|
|
|
|
use strict;
|
|
|
|
-use Test::More tests => 5;
|
|
+use Test::Builder::NoOutput;
|
|
+use Test::More tests => 7;
|
|
|
|
-my $Test = Test::More->builder;
|
|
+my $test = Test::Builder::NoOutput->create;
|
|
|
|
-# now make a filehandle where we can send data
|
|
-use TieOut;
|
|
-my $output = tie *FAKEOUT, 'TieOut';
|
|
-
|
|
-# force diagnostic output to a filehandle, glad I added this to
|
|
-# Test::Builder :)
|
|
-my $ret;
|
|
+# Test diag() goes to todo_output() in a todo test.
|
|
{
|
|
- local $TODO = 1;
|
|
- $Test->todo_output(\*FAKEOUT);
|
|
-
|
|
- diag("a single line");
|
|
-
|
|
- $ret = diag("multiple\n", "lines");
|
|
-}
|
|
+ $test->todo_start();
|
|
|
|
-is( $output->read, <<'DIAG', 'diag() with todo_output set' );
|
|
+ $test->diag("a single line");
|
|
+ is( $test->read('todo'), <<'DIAG', 'diag() with todo_output set' );
|
|
# a single line
|
|
+DIAG
|
|
+
|
|
+ my $ret = $test->diag("multiple\n", "lines");
|
|
+ is( $test->read('todo'), <<'DIAG', ' multi line' );
|
|
# multiple
|
|
# lines
|
|
DIAG
|
|
+ ok( !$ret, 'diag returns false' );
|
|
+
|
|
+ $test->todo_end();
|
|
+}
|
|
|
|
-ok( !$ret, 'diag returns false' );
|
|
|
|
+# Test diagnostic formatting
|
|
{
|
|
- $Test->failure_output(\*FAKEOUT);
|
|
- $ret = diag("# foo");
|
|
+ $test->diag("# foo");
|
|
+ is( $test->read('err'), "# # foo\n", "diag() adds # even if there's one already" );
|
|
+
|
|
+ $test->diag("foo\n\nbar");
|
|
+ is( $test->read('err'), <<'DIAG', " blank lines get escaped" );
|
|
+# foo
|
|
+#
|
|
+# bar
|
|
+DIAG
|
|
+
|
|
+ $test->diag("foo\n\nbar\n\n");
|
|
+ is( $test->read('err'), <<'DIAG', " even at the end" );
|
|
+# foo
|
|
+#
|
|
+# bar
|
|
+#
|
|
+DIAG
|
|
}
|
|
-$Test->failure_output(\*STDERR);
|
|
-is( $output->read, "# # foo\n", "diag() adds # even if there's one already" );
|
|
-ok( !$ret, 'diag returns false' );
|
|
|
|
|
|
-# [rt.cpan.org 8392]
|
|
+# [rt.cpan.org 8392] diag(@list) emulates print
|
|
{
|
|
- $Test->failure_output(\*FAKEOUT);
|
|
- diag(qw(one two));
|
|
-}
|
|
-$Test->failure_output(\*STDERR);
|
|
-is( $output->read, <<'DIAG' );
|
|
+ $test->diag(qw(one two));
|
|
+
|
|
+ is( $test->read('err'), <<'DIAG' );
|
|
# onetwo
|
|
DIAG
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/died.t perl-5.10.0/lib/Test/Simple/t/died.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/died.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/died.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,45 @@
|
|
+#!perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = '../lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+# Can't use Test.pm, that's a 5.005 thing.
|
|
+package My::Test;
|
|
+
|
|
+# This has to be a require or else the END block below runs before
|
|
+# Test::Builder's own and the ending diagnostics don't come out right.
|
|
+require Test::Builder;
|
|
+my $TB = Test::Builder->create;
|
|
+$TB->plan(tests => 3);
|
|
+
|
|
+
|
|
+package main;
|
|
+
|
|
+require Test::Simple;
|
|
+
|
|
+chdir 't';
|
|
+push @INC, '../t/lib/';
|
|
+require Test::Simple::Catch;
|
|
+my($out, $err) = Test::Simple::Catch::caught();
|
|
+local $ENV{HARNESS_ACTIVE} = 0;
|
|
+
|
|
+Test::Simple->import(tests => 1);
|
|
+exit 250;
|
|
+
|
|
+END {
|
|
+ $TB->is_eq($out->read, <<OUT);
|
|
+1..1
|
|
+OUT
|
|
+
|
|
+ $TB->is_eq($err->read, <<ERR);
|
|
+# Looks like your test exited with 250 before it could output anything.
|
|
+ERR
|
|
+
|
|
+ $TB->is_eq($?, 250, "exit code");
|
|
+
|
|
+ exit grep { !$_ } $TB->summary;
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_double.t perl-5.10.0/lib/Test/Simple/t/done_testing_double.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_double.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing_double.t 2009-08-26 06:14:40.000000000 +0200
|
|
@@ -0,0 +1,46 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = qw(../lib lib ../lib/Test/Simple/t/lib);
|
|
+ }
|
|
+}
|
|
+
|
|
+use strict;
|
|
+use lib 't/lib';
|
|
+
|
|
+use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
+
|
|
+my $tb = Test::Builder::NoOutput->create;
|
|
+
|
|
+{
|
|
+ # Normalize test output
|
|
+ local $ENV{HARNESS_ACTIVE};
|
|
+
|
|
+ $tb->ok(1);
|
|
+ $tb->ok(1);
|
|
+ $tb->ok(1);
|
|
+
|
|
+#line 24
|
|
+ $tb->done_testing(3);
|
|
+ $tb->done_testing;
|
|
+ $tb->done_testing;
|
|
+}
|
|
+
|
|
+my $Test = Test::Builder->new;
|
|
+$Test->plan( tests => 1 );
|
|
+$Test->level(0);
|
|
+$Test->is_eq($tb->read, <<"END", "multiple done_testing");
|
|
+ok 1
|
|
+ok 2
|
|
+ok 3
|
|
+1..3
|
|
+not ok 4 - done_testing() was already called at $0 line 24
|
|
+# Failed test 'done_testing() was already called at $0 line 24'
|
|
+# at $0 line 25.
|
|
+not ok 5 - done_testing() was already called at $0 line 24
|
|
+# Failed test 'done_testing() was already called at $0 line 24'
|
|
+# at $0 line 26.
|
|
+END
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_plan_mismatch.t perl-5.10.0/lib/Test/Simple/t/done_testing_plan_mismatch.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_plan_mismatch.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing_plan_mismatch.t 2009-08-26 06:14:43.000000000 +0200
|
|
@@ -0,0 +1,44 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = qw(../lib lib ../lib/Test/Simple/t/lib);
|
|
+ }
|
|
+}
|
|
+
|
|
+# What if there's a plan and done_testing but they don't match?
|
|
+
|
|
+use strict;
|
|
+use lib 't/lib';
|
|
+
|
|
+use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
+
|
|
+my $tb = Test::Builder::NoOutput->create;
|
|
+
|
|
+{
|
|
+ # Normalize test output
|
|
+ local $ENV{HARNESS_ACTIVE};
|
|
+
|
|
+ $tb->plan( tests => 3 );
|
|
+ $tb->ok(1);
|
|
+ $tb->ok(1);
|
|
+ $tb->ok(1);
|
|
+
|
|
+#line 24
|
|
+ $tb->done_testing(2);
|
|
+}
|
|
+
|
|
+my $Test = Test::Builder->new;
|
|
+$Test->plan( tests => 1 );
|
|
+$Test->level(0);
|
|
+$Test->is_eq($tb->read, <<"END");
|
|
+1..3
|
|
+ok 1
|
|
+ok 2
|
|
+ok 3
|
|
+not ok 4 - planned to run 3 but done_testing() expects 2
|
|
+# Failed test 'planned to run 3 but done_testing() expects 2'
|
|
+# at $0 line 24.
|
|
+END
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing.t perl-5.10.0/lib/Test/Simple/t/done_testing.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,12 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+use strict;
|
|
+
|
|
+use Test::Builder;
|
|
+
|
|
+my $tb = Test::Builder->new;
|
|
+$tb->level(0);
|
|
+
|
|
+$tb->ok(1, "testing done_testing() with no arguments");
|
|
+$tb->ok(1, " another test so we're not testing just one");
|
|
+$tb->done_testing();
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_no_plan.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_no_plan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_no_plan.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_no_plan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,11 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+use strict;
|
|
+
|
|
+use Test::Builder;
|
|
+
|
|
+my $tb = Test::Builder->new;
|
|
+$tb->plan( "no_plan" );
|
|
+$tb->ok(1);
|
|
+$tb->ok(1);
|
|
+$tb->done_testing(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_number.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_number.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_number.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_number.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,12 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+use strict;
|
|
+
|
|
+use Test::Builder;
|
|
+
|
|
+my $tb = Test::Builder->new;
|
|
+$tb->level(0);
|
|
+
|
|
+$tb->ok(1, "testing done_testing() with no arguments");
|
|
+$tb->ok(1, " another test so we're not testing just one");
|
|
+$tb->done_testing(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_plan.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_plan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_plan.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_plan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,11 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+use strict;
|
|
+
|
|
+use Test::Builder;
|
|
+
|
|
+my $tb = Test::Builder->new;
|
|
+$tb->plan( tests => 2 );
|
|
+$tb->ok(1);
|
|
+$tb->ok(1);
|
|
+$tb->done_testing(2);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/dont_overwrite_die_handler.t perl-5.10.0/lib/Test/Simple/t/dont_overwrite_die_handler.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/dont_overwrite_die_handler.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/dont_overwrite_die_handler.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -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 -urN perl-5.10.0.orig/lib/Test/Simple/t/exit.t perl-5.10.0/lib/Test/Simple/t/exit.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/exit.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/exit.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -10,59 +10,27 @@
|
|
}
|
|
}
|
|
|
|
-unless( eval { require File::Spec } ) {
|
|
- print "1..0 # Skip Need File::Spec to run this test\n";
|
|
- exit 0;
|
|
-}
|
|
-
|
|
-if( $^O eq 'VMS' && $] <= 5.00503 ) {
|
|
- print "1..0 # Skip test will hang on older VMS perls\n";
|
|
- exit 0;
|
|
-}
|
|
-
|
|
-if( $^O eq 'MacOS' ) {
|
|
- print "1..0 # Skip exit status broken on Mac OS\n";
|
|
- 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;
|
|
|
|
-my $IsVMS = $^O eq 'VMS';
|
|
+use Cwd;
|
|
+use File::Spec;
|
|
|
|
-print "# Ahh! I see you're running VMS.\n" if $IsVMS;
|
|
+my $Orig_Dir = cwd;
|
|
|
|
-my %Tests = (
|
|
- # Everyone Else VMS
|
|
- 'success.plx' => [0, 0],
|
|
- 'one_fail.plx' => [1, 4],
|
|
- 'two_fail.plx' => [2, 4],
|
|
- 'five_fail.plx' => [5, 4],
|
|
- 'extras.plx' => [2, 4],
|
|
- 'too_few.plx' => [255, 4],
|
|
- 'too_few_fail.plx' => [2, 4],
|
|
- 'death.plx' => [255, 4],
|
|
- 'last_minute_death.plx' => [255, 4],
|
|
- 'pre_plan_death.plx' => ['not zero', 'not zero'],
|
|
- 'death_in_eval.plx' => [0, 0],
|
|
- 'require.plx' => [0, 0],
|
|
- 'exit.plx' => [1, 4],
|
|
- );
|
|
+my $Perl = File::Spec->rel2abs($^X);
|
|
+if( $^O eq 'VMS' ) {
|
|
+ # VMS can't use its own $^X in a system call until almost 5.8
|
|
+ $Perl = "MCR $^X" if $] < 5.007003;
|
|
+
|
|
+ # Quiet noisy 'SYS$ABORT'
|
|
+ $Perl .= q{ -"Mvmsish=hushed"};
|
|
+}
|
|
|
|
-print "1..".keys(%Tests)."\n";
|
|
|
|
eval { require POSIX; &POSIX::WEXITSTATUS(0) };
|
|
if( $@ ) {
|
|
@@ -72,34 +40,74 @@
|
|
*exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
|
|
}
|
|
|
|
-chdir 't';
|
|
-my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
|
|
-while( my($test_name, $exit_codes) = each %Tests ) {
|
|
- my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0];
|
|
|
|
- my $Perl = $^X;
|
|
+# Some OS' will alter the exit code to their own native sense...
|
|
+# sometimes. Rather than deal with the exception we'll just
|
|
+# build up the mapping.
|
|
+print "# Building up a map of exit codes. May take a while.\n";
|
|
+my %Exit_Map;
|
|
+
|
|
+open my $fh, ">", "exit_map_test" or die $!;
|
|
+print $fh <<'DONE';
|
|
+if ($^O eq 'VMS') {
|
|
+ require vmsish;
|
|
+ import vmsish qw(hushed);
|
|
+}
|
|
+my $exit = shift;
|
|
+print "exit $exit\n";
|
|
+END { $? = $exit };
|
|
+DONE
|
|
+
|
|
+close $fh;
|
|
+END { 1 while unlink "exit_map_test" }
|
|
+
|
|
+for my $exit (0..255) {
|
|
+ # This correctly emulates Test::Builder's behavior.
|
|
+ my $out = qx[$Perl exit_map_test $exit];
|
|
+ $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" );
|
|
+ $Exit_Map{$exit} = exitstatus($?);
|
|
+}
|
|
+print "# Done.\n";
|
|
+
|
|
|
|
- if( $^O eq 'VMS' ) {
|
|
- # VMS can't use its own $^X in a system call until almost 5.8
|
|
- $Perl = "MCR $^X" if $] < 5.007003;
|
|
-
|
|
- # Quiet noisy 'SYS$ABORT'. 'hushed' only exists in 5.6 and up,
|
|
- # but it doesn't do any harm on eariler perls.
|
|
- $Perl .= q{ -"Mvmsish=hushed"};
|
|
- }
|
|
+my %Tests = (
|
|
+ # File Exit Code
|
|
+ 'success.plx' => 0,
|
|
+ 'one_fail.plx' => 1,
|
|
+ 'two_fail.plx' => 2,
|
|
+ 'five_fail.plx' => 5,
|
|
+ 'extras.plx' => 2,
|
|
+ 'too_few.plx' => 255,
|
|
+ 'too_few_fail.plx' => 2,
|
|
+ 'death.plx' => 255,
|
|
+ 'last_minute_death.plx' => 255,
|
|
+ 'pre_plan_death.plx' => 'not zero',
|
|
+ 'death_in_eval.plx' => 0,
|
|
+ 'require.plx' => 0,
|
|
+ 'death_with_handler.plx' => 255,
|
|
+ 'exit.plx' => 1,
|
|
+ );
|
|
|
|
+chdir 't';
|
|
+my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
|
|
+while( my($test_name, $exit_code) = each %Tests ) {
|
|
my $file = File::Spec->catfile($lib, $test_name);
|
|
my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
|
|
my $actual_exit = exitstatus($wait_stat);
|
|
|
|
if( $exit_code eq 'not zero' ) {
|
|
- My::Test::ok( $actual_exit != 0,
|
|
+ $TB->isnt_num( $actual_exit, $Exit_Map{0},
|
|
"$test_name exited with $actual_exit ".
|
|
- "(expected $exit_code)");
|
|
+ "(expected non-zero)");
|
|
}
|
|
else {
|
|
- My::Test::ok( $actual_exit == $exit_code,
|
|
+ $TB->is_num( $actual_exit, $Exit_Map{$exit_code},
|
|
"$test_name exited with $actual_exit ".
|
|
- "(expected $exit_code)");
|
|
+ "(expected $Exit_Map{$exit_code})");
|
|
}
|
|
}
|
|
+
|
|
+$TB->done_testing( scalar keys(%Tests) + 256 );
|
|
+
|
|
+# So any END block file cleanup works.
|
|
+chdir $Orig_Dir;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/explain.t perl-5.10.0/lib/Test/Simple/t/explain.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/explain.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/explain.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,27 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = ('../lib', 'lib');
|
|
+ }
|
|
+ else {
|
|
+ unshift @INC, 't/lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+use strict;
|
|
+use warnings;
|
|
+
|
|
+use Test::More tests => 5;
|
|
+
|
|
+can_ok "main", "explain";
|
|
+
|
|
+is_deeply [explain("foo")], ["foo"];
|
|
+is_deeply [explain("foo", "bar")], ["foo", "bar"];
|
|
+
|
|
+# Avoid future dump formatting changes from breaking tests by just eval'ing
|
|
+# the dump
|
|
+is_deeply [map { eval $_ } explain([], {})], [[], {}];
|
|
+
|
|
+is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99];
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/extra_one.t perl-5.10.0/lib/Test/Simple/t/extra_one.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/extra_one.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/extra_one.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -44,7 +44,7 @@
|
|
OUT
|
|
|
|
My::Test::is($$err, <<ERR);
|
|
-# Looks like you planned 1 test but ran 2 extra.
|
|
+# Looks like you planned 1 test but ran 3.
|
|
ERR
|
|
|
|
# Prevent Test::Simple from existing with non-zero
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/extra.t perl-5.10.0/lib/Test/Simple/t/extra.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/extra.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/extra.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -51,7 +51,7 @@
|
|
# at $0 line 31.
|
|
# Failed test 'Sar'
|
|
# at $0 line 34.
|
|
-# Looks like you planned 3 tests but ran 2 extra.
|
|
+# Looks like you planned 3 tests but ran 5.
|
|
# Looks like you failed 2 tests of 5 run.
|
|
ERR
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail-like.t perl-5.10.0/lib/Test/Simple/t/fail-like.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/fail-like.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/fail-like.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,11 +1,4 @@
|
|
-# qr// was introduced in 5.004-devel. Skip this test if we're not
|
|
-# of high enough version.
|
|
-BEGIN {
|
|
- if( $] < 5.005 ) {
|
|
- print "1..0 # Skipped Test requires qr//\n";
|
|
- exit(0);
|
|
- }
|
|
-}
|
|
+#!/usr/bin/perl -w
|
|
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
@@ -30,7 +23,7 @@
|
|
# Test::Builder's own and the ending diagnostics don't come out right.
|
|
require Test::Builder;
|
|
my $TB = Test::Builder->create;
|
|
-$TB->plan(tests => 2);
|
|
+$TB->plan(tests => 4);
|
|
|
|
|
|
require Test::Simple::Catch;
|
|
@@ -43,11 +36,10 @@
|
|
require Test::More;
|
|
Test::More->import(tests => 1);
|
|
|
|
-eval q{ like( "foo", qr/that/, 'is foo like that' ); };
|
|
-
|
|
+{
|
|
+ eval q{ like( "foo", qr/that/, 'is foo like that' ); };
|
|
|
|
-END {
|
|
- $TB->is_eq($$out, <<OUT, 'failing output');
|
|
+ $TB->is_eq($out->read, <<OUT, 'failing output');
|
|
1..1
|
|
not ok 1 - is foo like that
|
|
OUT
|
|
@@ -57,11 +49,26 @@
|
|
# at .* line 1\.
|
|
# 'foo'
|
|
# doesn't match '\\(\\?-xism:that\\)'
|
|
-# Looks like you failed 1 test of 1\\.
|
|
ERR
|
|
|
|
+ $TB->like($err->read, qr/^$err_re$/, 'failing errors');
|
|
+}
|
|
|
|
- $TB->like($$err, qr/^$err_re$/, 'failing errors');
|
|
+{
|
|
+ # line 59
|
|
+ like("foo", "not a regex");
|
|
+ $TB->is_eq($out->read, <<OUT);
|
|
+not ok 2
|
|
+OUT
|
|
|
|
- exit(0);
|
|
+ $TB->is_eq($err->read, <<OUT);
|
|
+# Failed test at $0 line 59.
|
|
+# 'not a regex' doesn't look much like a regex to me.
|
|
+OUT
|
|
+
|
|
+}
|
|
+
|
|
+END {
|
|
+ # Test::More thinks it failed. Override that.
|
|
+ exit(scalar grep { !$_ } $TB->summary);
|
|
}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail-more.t perl-5.10.0/lib/Test/Simple/t/fail-more.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/fail-more.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/fail-more.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -24,7 +24,7 @@
|
|
# Test::Builder's own and the ending diagnostics don't come out right.
|
|
require Test::Builder;
|
|
my $TB = Test::Builder->create;
|
|
-$TB->plan(tests => 17);
|
|
+$TB->plan(tests => 78);
|
|
|
|
sub like ($$;$) {
|
|
$TB->like(@_);
|
|
@@ -34,19 +34,26 @@
|
|
$TB->is_eq(@_);
|
|
}
|
|
|
|
-sub main::err_ok ($) {
|
|
- my($expect) = @_;
|
|
- my $got = $err->read;
|
|
+sub main::out_ok ($$) {
|
|
+ $TB->is_eq( $out->read, shift );
|
|
+ $TB->is_eq( $err->read, shift );
|
|
+}
|
|
+
|
|
+sub main::out_like ($$) {
|
|
+ my($output, $failure) = @_;
|
|
|
|
- return $TB->is_eq( $got, $expect );
|
|
+ $TB->like( $out->read, qr/$output/ );
|
|
+ $TB->like( $err->read, qr/$failure/ );
|
|
}
|
|
|
|
|
|
package main;
|
|
|
|
require Test::More;
|
|
-my $Total = 30;
|
|
+our $TODO;
|
|
+my $Total = 37;
|
|
Test::More->import(tests => $Total);
|
|
+$out->read; # clear the plan from $out
|
|
|
|
# This should all work in the presence of a __DIE__ handler.
|
|
local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); };
|
|
@@ -57,184 +64,387 @@
|
|
|
|
my $Filename = quotemeta $0;
|
|
|
|
-# Preserve the line numbers.
|
|
+
|
|
#line 38
|
|
ok( 0, 'failing' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - failing
|
|
+OUT
|
|
# Failed test 'failing'
|
|
# at $0 line 38.
|
|
ERR
|
|
|
|
+
|
|
#line 40
|
|
is( "foo", "bar", 'foo is bar?');
|
|
-is( undef, '', 'undef is empty string?');
|
|
-is( undef, 0, 'undef is 0?');
|
|
-is( '', 0, 'empty string is 0?' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - foo is bar?
|
|
+OUT
|
|
# Failed test 'foo is bar?'
|
|
# at $0 line 40.
|
|
# got: 'foo'
|
|
# expected: 'bar'
|
|
+ERR
|
|
+
|
|
+#line 89
|
|
+is( undef, '', 'undef is empty string?');
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - undef is empty string?
|
|
+OUT
|
|
# Failed test 'undef is empty string?'
|
|
-# at $0 line 41.
|
|
+# at $0 line 89.
|
|
# got: undef
|
|
# expected: ''
|
|
+ERR
|
|
+
|
|
+#line 99
|
|
+is( undef, 0, 'undef is 0?');
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - undef is 0?
|
|
+OUT
|
|
# Failed test 'undef is 0?'
|
|
-# at $0 line 42.
|
|
+# at $0 line 99.
|
|
# got: undef
|
|
# expected: '0'
|
|
+ERR
|
|
+
|
|
+#line 110
|
|
+is( '', 0, 'empty string is 0?' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - empty string is 0?
|
|
+OUT
|
|
# Failed test 'empty string is 0?'
|
|
-# at $0 line 43.
|
|
+# at $0 line 110.
|
|
# got: ''
|
|
# expected: '0'
|
|
ERR
|
|
|
|
-#line 45
|
|
+#line 121
|
|
isnt("foo", "foo", 'foo isnt foo?' );
|
|
-isn't("foo", "foo",'foo isn\'t foo?' );
|
|
-isnt(undef, undef, 'undef isnt undef?');
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - foo isnt foo?
|
|
+OUT
|
|
# Failed test 'foo isnt foo?'
|
|
-# at $0 line 45.
|
|
-# 'foo'
|
|
-# ne
|
|
-# 'foo'
|
|
+# at $0 line 121.
|
|
+# got: 'foo'
|
|
+# expected: anything else
|
|
+ERR
|
|
+
|
|
+#line 132
|
|
+isn't("foo", "foo",'foo isn\'t foo?' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - foo isn't foo?
|
|
+OUT
|
|
# Failed test 'foo isn\'t foo?'
|
|
-# at $0 line 46.
|
|
-# 'foo'
|
|
-# ne
|
|
-# 'foo'
|
|
+# at $0 line 132.
|
|
+# got: 'foo'
|
|
+# expected: anything else
|
|
+ERR
|
|
+
|
|
+#line 143
|
|
+isnt(undef, undef, 'undef isnt undef?');
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - undef isnt undef?
|
|
+OUT
|
|
# Failed test 'undef isnt undef?'
|
|
-# at $0 line 47.
|
|
-# undef
|
|
-# ne
|
|
-# undef
|
|
+# at $0 line 143.
|
|
+# got: undef
|
|
+# expected: anything else
|
|
ERR
|
|
|
|
-#line 48
|
|
+#line 154
|
|
like( "foo", '/that/', 'is foo like that' );
|
|
-unlike( "foo", '/foo/', 'is foo unlike foo' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - is foo like that
|
|
+OUT
|
|
# Failed test 'is foo like that'
|
|
-# at $0 line 48.
|
|
+# at $0 line 154.
|
|
# 'foo'
|
|
# doesn't match '/that/'
|
|
+ERR
|
|
+
|
|
+#line 165
|
|
+unlike( "foo", '/foo/', 'is foo unlike foo' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - is foo unlike foo
|
|
+OUT
|
|
# Failed test 'is foo unlike foo'
|
|
-# at $0 line 49.
|
|
+# at $0 line 165.
|
|
# 'foo'
|
|
# matches '/foo/'
|
|
ERR
|
|
|
|
# Nick Clark found this was a bug. Fixed in 0.40.
|
|
-# line 60
|
|
+# line 177
|
|
like( "bug", '/(%)/', 'regex with % in it' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - regex with % in it
|
|
+OUT
|
|
# Failed test 'regex with % in it'
|
|
-# at $0 line 60.
|
|
+# at $0 line 177.
|
|
# 'bug'
|
|
# doesn't match '/(%)/'
|
|
ERR
|
|
|
|
-#line 67
|
|
+#line 188
|
|
fail('fail()');
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - fail()
|
|
+OUT
|
|
# Failed test 'fail()'
|
|
-# at $0 line 67.
|
|
+# at $0 line 188.
|
|
ERR
|
|
|
|
-#line 52
|
|
+#line 197
|
|
can_ok('Mooble::Hooble::Yooble', qw(this that));
|
|
-can_ok('Mooble::Hooble::Yooble', ());
|
|
-can_ok(undef, undef);
|
|
-can_ok([], "foo");
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - Mooble::Hooble::Yooble->can(...)
|
|
+OUT
|
|
# Failed test 'Mooble::Hooble::Yooble->can(...)'
|
|
-# at $0 line 52.
|
|
+# at $0 line 197.
|
|
# Mooble::Hooble::Yooble->can('this') failed
|
|
# Mooble::Hooble::Yooble->can('that') failed
|
|
+ERR
|
|
+
|
|
+#line 208
|
|
+can_ok('Mooble::Hooble::Yooble', ());
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - Mooble::Hooble::Yooble->can(...)
|
|
+OUT
|
|
# Failed test 'Mooble::Hooble::Yooble->can(...)'
|
|
-# at $0 line 53.
|
|
+# at $0 line 208.
|
|
# can_ok() called with no methods
|
|
+ERR
|
|
+
|
|
+#line 218
|
|
+can_ok(undef, undef);
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - ->can(...)
|
|
+OUT
|
|
# Failed test '->can(...)'
|
|
-# at $0 line 54.
|
|
+# at $0 line 218.
|
|
# can_ok() called with empty class or reference
|
|
+ERR
|
|
+
|
|
+#line 228
|
|
+can_ok([], "foo");
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - ARRAY->can('foo')
|
|
+OUT
|
|
# Failed test 'ARRAY->can('foo')'
|
|
-# at $0 line 55.
|
|
+# at $0 line 228.
|
|
# ARRAY->can('foo') failed
|
|
ERR
|
|
|
|
-#line 55
|
|
+#line 238
|
|
isa_ok(bless([], "Foo"), "Wibble");
|
|
-isa_ok(42, "Wibble", "My Wibble");
|
|
-isa_ok(undef, "Wibble", "Another Wibble");
|
|
-isa_ok([], "HASH");
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - The object isa Wibble
|
|
+OUT
|
|
# Failed test 'The object isa Wibble'
|
|
-# at $0 line 55.
|
|
+# at $0 line 238.
|
|
# The object isn't a 'Wibble' it's a 'Foo'
|
|
+ERR
|
|
+
|
|
+#line 248
|
|
+isa_ok(42, "Wibble", "My Wibble");
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - My Wibble isa Wibble
|
|
+OUT
|
|
# Failed test 'My Wibble isa Wibble'
|
|
-# at $0 line 56.
|
|
-# My Wibble isn't a reference
|
|
+# at $0 line 248.
|
|
+# My Wibble isn't a class or reference
|
|
+ERR
|
|
+
|
|
+#line 258
|
|
+isa_ok(undef, "Wibble", "Another Wibble");
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - Another Wibble isa Wibble
|
|
+OUT
|
|
# Failed test 'Another Wibble isa Wibble'
|
|
-# at $0 line 57.
|
|
+# at $0 line 258.
|
|
# Another Wibble isn't defined
|
|
-# Failed test 'The object isa HASH'
|
|
-# at $0 line 58.
|
|
-# The object isn't a 'HASH' it's a 'ARRAY'
|
|
ERR
|
|
|
|
-#line 68
|
|
+#line 268
|
|
+isa_ok([], "HASH");
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - The reference isa HASH
|
|
+OUT
|
|
+# Failed test 'The reference isa HASH'
|
|
+# at $0 line 268.
|
|
+# The reference isn't a 'HASH' it's a 'ARRAY'
|
|
+ERR
|
|
+
|
|
+#line 278
|
|
+new_ok(undef);
|
|
+out_like( <<OUT, <<ERR );
|
|
+not ok - new\\(\\) died
|
|
+OUT
|
|
+# Failed test 'new\\(\\) died'
|
|
+# at $Filename line 278.
|
|
+# Error was: Can't call method "new" on an undefined value at .*
|
|
+ERR
|
|
+
|
|
+#line 288
|
|
+new_ok( "Does::Not::Exist" );
|
|
+out_like( <<OUT, <<ERR );
|
|
+not ok - new\\(\\) died
|
|
+OUT
|
|
+# Failed test 'new\\(\\) died'
|
|
+# at $Filename line 288.
|
|
+# Error was: Can't locate object method "new" via package "Does::Not::Exist" .*
|
|
+ERR
|
|
+
|
|
+
|
|
+{ package Foo; sub new { } }
|
|
+{ package Bar; sub new { {} } }
|
|
+{ package Baz; sub new { bless {}, "Wibble" } }
|
|
+
|
|
+#line 303
|
|
+new_ok( "Foo" );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - The object isa Foo
|
|
+OUT
|
|
+# Failed test 'The object isa Foo'
|
|
+# at $0 line 303.
|
|
+# The object isn't defined
|
|
+ERR
|
|
+
|
|
+# line 313
|
|
+new_ok( "Bar" );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - The object isa Bar
|
|
+OUT
|
|
+# Failed test 'The object isa Bar'
|
|
+# at $0 line 313.
|
|
+# The object isn't a 'Bar' it's a 'HASH'
|
|
+ERR
|
|
+
|
|
+#line 323
|
|
+new_ok( "Baz" );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - The object isa Baz
|
|
+OUT
|
|
+# Failed test 'The object isa Baz'
|
|
+# at $0 line 323.
|
|
+# The object isn't a 'Baz' it's a 'Wibble'
|
|
+ERR
|
|
+
|
|
+#line 333
|
|
+new_ok( "Baz", [], "no args" );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - no args isa Baz
|
|
+OUT
|
|
+# Failed test 'no args isa Baz'
|
|
+# at $0 line 333.
|
|
+# no args isn't a 'Baz' it's a 'Wibble'
|
|
+ERR
|
|
+
|
|
+#line 343
|
|
cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' );
|
|
-cmp_ok( 42.1, '==', 23, , ' ==' );
|
|
-cmp_ok( 42, '!=', 42 , ' !=' );
|
|
-cmp_ok( 1, '&&', 0 , ' &&' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - cmp_ok eq
|
|
+OUT
|
|
# Failed test 'cmp_ok eq'
|
|
-# at $0 line 68.
|
|
+# at $0 line 343.
|
|
# got: 'foo'
|
|
# expected: 'bar'
|
|
+ERR
|
|
+
|
|
+#line 354
|
|
+cmp_ok( 42.1, '==', 23, , ' ==' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - ==
|
|
+OUT
|
|
# Failed test ' =='
|
|
-# at $0 line 69.
|
|
+# at $0 line 354.
|
|
# got: 42.1
|
|
# expected: 23
|
|
+ERR
|
|
+
|
|
+#line 365
|
|
+cmp_ok( 42, '!=', 42 , ' !=' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - !=
|
|
+OUT
|
|
# Failed test ' !='
|
|
-# at $0 line 70.
|
|
-# '42'
|
|
-# !=
|
|
-# '42'
|
|
+# at $0 line 365.
|
|
+# got: 42
|
|
+# expected: anything else
|
|
+ERR
|
|
+
|
|
+#line 376
|
|
+cmp_ok( 1, '&&', 0 , ' &&' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - &&
|
|
+OUT
|
|
# Failed test ' &&'
|
|
-# at $0 line 71.
|
|
+# at $0 line 376.
|
|
# '1'
|
|
# &&
|
|
# '0'
|
|
ERR
|
|
|
|
-
|
|
-# line 196
|
|
+# line 388
|
|
cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - eq with numbers
|
|
+OUT
|
|
# Failed test ' eq with numbers'
|
|
-# at $0 line 196.
|
|
+# at $0 line 388.
|
|
# got: '42'
|
|
# expected: 'foo'
|
|
ERR
|
|
|
|
-
|
|
{
|
|
- my $warnings;
|
|
+ my $warnings = '';
|
|
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
|
|
|
|
-# line 211
|
|
+# line 404
|
|
cmp_ok( 42, '==', "foo", ' == with strings' );
|
|
- err_ok( <<ERR );
|
|
+ out_ok( <<OUT, <<ERR );
|
|
+not ok - == with strings
|
|
+OUT
|
|
# Failed test ' == with strings'
|
|
-# at $0 line 211.
|
|
+# at $0 line 404.
|
|
# got: 42
|
|
# expected: foo
|
|
ERR
|
|
- My::Test::like $warnings,
|
|
- qq[/^Argument "foo" isn't numeric in .* at $Filename line 211\\\.\n\$/];
|
|
+ My::Test::like(
|
|
+ $warnings,
|
|
+ qr/^Argument "foo" isn't numeric in .* at cmp_ok \[from $Filename line 404\] line 1\.\n$/
|
|
+ );
|
|
+ $warnings = '';
|
|
+}
|
|
+
|
|
+
|
|
+{
|
|
+ my $warnings = '';
|
|
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
|
|
|
|
+#line 426
|
|
+ cmp_ok( undef, "ne", "", "undef ne empty string" );
|
|
+
|
|
+ $TB->is_eq( $out->read, <<OUT );
|
|
+not ok - undef ne empty string
|
|
+OUT
|
|
+
|
|
+ TODO: {
|
|
+ local $::TODO = 'cmp_ok() gives the wrong "expected" for undef';
|
|
+
|
|
+ $TB->is_eq( $err->read, <<ERR );
|
|
+# Failed test 'undef ne empty string'
|
|
+# at $0 line 426.
|
|
+# got: undef
|
|
+# expected: ''
|
|
+ERR
|
|
+ }
|
|
+
|
|
+ My::Test::like(
|
|
+ $warnings,
|
|
+ qr/^Use of uninitialized value.* in string ne at cmp_ok \[from $Filename line 426\] line 1\.\n\z/
|
|
+ );
|
|
}
|
|
|
|
|
|
@@ -242,82 +452,58 @@
|
|
-e "wibblehibble";
|
|
my $Errno_Number = $!+0;
|
|
my $Errno_String = $!.'';
|
|
-#line 80
|
|
+#line 425
|
|
cmp_ok( $!, 'eq', '', ' eq with stringified errno' );
|
|
-cmp_ok( $!, '==', -1, ' eq with numerified errno' );
|
|
-err_ok( <<ERR );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - eq with stringified errno
|
|
+OUT
|
|
# Failed test ' eq with stringified errno'
|
|
-# at $0 line 80.
|
|
+# at $0 line 425.
|
|
# got: '$Errno_String'
|
|
# expected: ''
|
|
+ERR
|
|
+
|
|
+#line 436
|
|
+cmp_ok( $!, '==', -1, ' eq with numerified errno' );
|
|
+out_ok( <<OUT, <<ERR );
|
|
+not ok - eq with numerified errno
|
|
+OUT
|
|
# Failed test ' eq with numerified errno'
|
|
-# at $0 line 81.
|
|
+# at $0 line 436.
|
|
# got: $Errno_Number
|
|
# expected: -1
|
|
ERR
|
|
|
|
-#line 84
|
|
+#line 447
|
|
use_ok('Hooble::mooble::yooble');
|
|
-
|
|
my $more_err_re = <<ERR;
|
|
# Failed test 'use Hooble::mooble::yooble;'
|
|
-# at $Filename line 84\\.
|
|
+# at $Filename line 447\\.
|
|
# Tried to use 'Hooble::mooble::yooble'.
|
|
# Error: Can't locate Hooble.* in \\\@INC .*
|
|
ERR
|
|
+out_like(
|
|
+ qr/^\Qnot ok - use Hooble::mooble::yooble;\E\n\z/,
|
|
+ qr/^$more_err_re/
|
|
+);
|
|
|
|
-My::Test::like($err->read, "/^$more_err_re/");
|
|
-
|
|
-
|
|
-#line 85
|
|
+#line 460
|
|
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;'
|
|
-# at $Filename line 85\\.
|
|
+# at $Filename line 460\\.
|
|
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
|
|
# Error: Can't locate ALL.* in \\\@INC .*
|
|
ERR
|
|
-
|
|
-My::Test::like($err->read, "/^$more_err_re/");
|
|
+out_like(
|
|
+ qr/^\Qnot ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;\E\n\z/,
|
|
+ qr/^$more_err_re/
|
|
+);
|
|
|
|
|
|
-#line 88
|
|
END {
|
|
- $TB->is_eq($$out, <<OUT, 'failing output');
|
|
-1..$Total
|
|
-not ok - failing
|
|
-not ok - foo is bar?
|
|
-not ok - undef is empty string?
|
|
-not ok - undef is 0?
|
|
-not ok - empty string is 0?
|
|
-not ok - foo isnt foo?
|
|
-not ok - foo isn't foo?
|
|
-not ok - undef isnt undef?
|
|
-not ok - is foo like that
|
|
-not ok - is foo unlike foo
|
|
-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
|
|
-not ok - The object isa HASH
|
|
-not ok - cmp_ok eq
|
|
-not ok - ==
|
|
-not ok - !=
|
|
-not ok - &&
|
|
-not ok - eq with numbers
|
|
-not ok - == with strings
|
|
-not ok - eq with stringified errno
|
|
-not ok - eq with numerified errno
|
|
-not ok - use Hooble::mooble::yooble;
|
|
-not ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
|
|
+ out_like( <<OUT, <<ERR );
|
|
OUT
|
|
-
|
|
-err_ok( <<ERR );
|
|
# Looks like you failed $Total tests of $Total.
|
|
ERR
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail_one.t perl-5.10.0/lib/Test/Simple/t/fail_one.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/fail_one.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/fail_one.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -12,51 +12,32 @@
|
|
|
|
use strict;
|
|
|
|
-require Test::Simple::Catch;
|
|
-my($out, $err) = Test::Simple::Catch::caught();
|
|
+# Normalize the output whether we're running under Test::Harness or not.
|
|
local $ENV{HARNESS_ACTIVE} = 0;
|
|
|
|
+use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
|
|
-# Can't use Test.pm, that's a 5.005 thing.
|
|
-package My::Test;
|
|
+my $Test = Test::Builder->new;
|
|
|
|
-print "1..2\n";
|
|
+{
|
|
+ my $tb = Test::Builder::NoOutput->create;
|
|
|
|
-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++;
|
|
+ $tb->plan( tests => 1 );
|
|
|
|
- return $test ? 1 : 0;
|
|
-}
|
|
-
|
|
-
|
|
-package main;
|
|
-
|
|
-require Test::Simple;
|
|
-Test::Simple->import(tests => 1);
|
|
-
|
|
-#line 45
|
|
-ok(0);
|
|
+#line 28
|
|
+ $tb->ok(0);
|
|
+ $tb->_ending;
|
|
|
|
-END {
|
|
- My::Test::ok($$out eq <<OUT);
|
|
+ $Test->is_eq($tb->read('out'), <<OUT);
|
|
1..1
|
|
not ok 1
|
|
OUT
|
|
|
|
- My::Test::ok($$err eq <<ERR) || print $$err;
|
|
-# Failed test at $0 line 45.
|
|
+ $Test->is_eq($tb->read('err'), <<ERR);
|
|
+# Failed test at $0 line 28.
|
|
# Looks like you failed 1 test of 1.
|
|
ERR
|
|
|
|
- # Prevent Test::Simple from existing with non-zero
|
|
- exit 0;
|
|
+ $Test->done_testing(2);
|
|
}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail.t perl-5.10.0/lib/Test/Simple/t/fail.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/fail.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/fail.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,5 +1,7 @@
|
|
#!perl -w
|
|
|
|
+# Simple test of what failure output looks like
|
|
+
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
@@ -12,45 +14,28 @@
|
|
|
|
use strict;
|
|
|
|
-require Test::Simple::Catch;
|
|
-my($out, $err) = Test::Simple::Catch::caught();
|
|
+# Normalize the output whether we're running under Test::Harness or not.
|
|
local $ENV{HARNESS_ACTIVE} = 0;
|
|
|
|
+use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
|
|
-# Can't use Test.pm, that's a 5.005 thing.
|
|
-package My::Test;
|
|
-
|
|
-print "1..2\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;
|
|
-Test::Simple->import(tests => 5);
|
|
-
|
|
-#line 35
|
|
-ok( 1, 'passing' );
|
|
-ok( 2, 'passing still' );
|
|
-ok( 3, 'still passing' );
|
|
-ok( 0, 'oh no!' );
|
|
-ok( 0, 'damnit' );
|
|
+my $Test = Test::Builder->new;
|
|
|
|
+# Set up a builder to record some failing tests.
|
|
+{
|
|
+ my $tb = Test::Builder::NoOutput->create;
|
|
+ $tb->plan( tests => 5 );
|
|
+
|
|
+#line 28
|
|
+ $tb->ok( 1, 'passing' );
|
|
+ $tb->ok( 2, 'passing still' );
|
|
+ $tb->ok( 3, 'still passing' );
|
|
+ $tb->ok( 0, 'oh no!' );
|
|
+ $tb->ok( 0, 'damnit' );
|
|
+ $tb->_ending;
|
|
|
|
-END {
|
|
- My::Test::ok($$out eq <<OUT);
|
|
+ $Test->is_eq($tb->read('out'), <<OUT);
|
|
1..5
|
|
ok 1 - passing
|
|
ok 2 - passing still
|
|
@@ -59,14 +44,13 @@
|
|
not ok 5 - damnit
|
|
OUT
|
|
|
|
- My::Test::ok($$err eq <<ERR);
|
|
+ $Test->is_eq($tb->read('err'), <<ERR);
|
|
# Failed test 'oh no!'
|
|
-# at $0 line 38.
|
|
+# at $0 line 31.
|
|
# Failed test 'damnit'
|
|
-# at $0 line 39.
|
|
+# at $0 line 32.
|
|
# Looks like you failed 2 tests of 5.
|
|
ERR
|
|
|
|
- # Prevent Test::Simple from exiting with non zero
|
|
- exit 0;
|
|
+ $Test->done_testing(2);
|
|
}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/filehandles.t perl-5.10.0/lib/Test/Simple/t/filehandles.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/filehandles.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/filehandles.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -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 }
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fork_with_new_stdout.t perl-5.10.0/lib/Test/Simple/t/fork_with_new_stdout.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/fork_with_new_stdout.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/fork_with_new_stdout.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,54 @@
|
|
+#!perl -w
|
|
+use strict;
|
|
+use warnings;
|
|
+use IO::Pipe;
|
|
+use Test::Builder;
|
|
+use Config;
|
|
+
|
|
+my $b = Test::Builder->new;
|
|
+$b->reset;
|
|
+
|
|
+my $Can_Fork = $Config{d_fork} ||
|
|
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
|
|
+ $Config{useithreads} and
|
|
+ $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
|
|
+ );
|
|
+
|
|
+if( !$Can_Fork ) {
|
|
+ $b->plan('skip_all' => "This system cannot fork");
|
|
+}
|
|
+else {
|
|
+ $b->plan('tests' => 2);
|
|
+}
|
|
+
|
|
+my $pipe = IO::Pipe->new;
|
|
+if ( my $pid = fork ) {
|
|
+ $pipe->reader;
|
|
+ $b->ok((<$pipe> =~ /FROM CHILD: ok 1/), "ok 1 from child");
|
|
+ $b->ok((<$pipe> =~ /FROM CHILD: 1\.\.1/), "1..1 from child");
|
|
+ waitpid($pid, 0);
|
|
+}
|
|
+else {
|
|
+ $pipe->writer;
|
|
+ my $pipe_fd = $pipe->fileno;
|
|
+ close STDOUT;
|
|
+ open(STDOUT, ">&$pipe_fd");
|
|
+ my $b = Test::Builder->new;
|
|
+ $b->reset;
|
|
+ $b->no_plan;
|
|
+ $b->ok(1);
|
|
+}
|
|
+
|
|
+
|
|
+=pod
|
|
+#actual
|
|
+1..2
|
|
+ok 1
|
|
+1..1
|
|
+ok 1
|
|
+ok 2
|
|
+#expected
|
|
+1..2
|
|
+ok 1
|
|
+ok 2
|
|
+=cut
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_dne_bug.t perl-5.10.0/lib/Test/Simple/t/is_deeply_dne_bug.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_dne_bug.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/is_deeply_dne_bug.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -16,16 +16,7 @@
|
|
}
|
|
|
|
use strict;
|
|
-use Test::More;
|
|
-
|
|
-BEGIN {
|
|
- if( !eval "require overload" ) {
|
|
- plan skip_all => "needs overload.pm";
|
|
- }
|
|
- else {
|
|
- plan tests => 2;
|
|
- }
|
|
-}
|
|
+use Test::More tests => 2;
|
|
|
|
{
|
|
package Foo;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_fail.t perl-5.10.0/lib/Test/Simple/t/is_deeply_fail.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_fail.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/is_deeply_fail.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -317,7 +317,8 @@
|
|
ERR
|
|
|
|
|
|
- if( eval { require overload } ) {
|
|
+ # Overloaded object tests
|
|
+ {
|
|
my $foo = bless [], "Foo";
|
|
my $bar = bless {}, "Bar";
|
|
|
|
@@ -337,9 +338,6 @@
|
|
ERR
|
|
|
|
}
|
|
- else {
|
|
- $TB->skip("Needs overload.pm") for 1..3;
|
|
- }
|
|
}
|
|
|
|
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_with_threads.t perl-5.10.0/lib/Test/Simple/t/is_deeply_with_threads.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_with_threads.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/is_deeply_with_threads.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -19,7 +19,12 @@
|
|
unless ( $] >= 5.008001 && $Config{'useithreads'} &&
|
|
eval { require threads; 'threads'->import; 1; })
|
|
{
|
|
- print "1..0 # Skip: no working threads\n";
|
|
+ print "1..0 # Skip no working threads\n";
|
|
+ exit 0;
|
|
+ }
|
|
+
|
|
+ unless ( $ENV{AUTHOR_TESTING} ) {
|
|
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
|
|
exit 0;
|
|
}
|
|
}
|
|
@@ -27,7 +32,7 @@
|
|
|
|
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");
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/Dev/Null.pm perl-5.10.0/lib/Test/Simple/t/lib/Dev/Null.pm
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/lib/Dev/Null.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/lib/Dev/Null.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,8 @@
|
|
+package Dev::Null;
|
|
+
|
|
+use strict;
|
|
+
|
|
+sub TIEHANDLE { bless {}, shift }
|
|
+sub PRINT { 1 }
|
|
+
|
|
+1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/Dummy.pm perl-5.10.0/lib/Test/Simple/t/lib/Dummy.pm
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/lib/Dummy.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/lib/Dummy.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,5 +1,6 @@
|
|
package Dummy;
|
|
|
|
-$VERSION = '0.01';
|
|
+use strict;
|
|
+our $VERSION = '0.01';
|
|
|
|
-1;
|
|
\ No newline at end of file
|
|
+1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/MyOverload.pm perl-5.10.0/lib/Test/Simple/t/lib/MyOverload.pm
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/lib/MyOverload.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/lib/MyOverload.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,29 +1,30 @@
|
|
-package Overloaded;
|
|
+package Overloaded; ##no critic (Modules::RequireFilenameMatchesPackage)
|
|
+
|
|
+use strict;
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
bless { string => shift, num => shift }, $class;
|
|
}
|
|
|
|
-
|
|
package Overloaded::Compare;
|
|
-use vars qw(@ISA);
|
|
-@ISA = qw(Overloaded);
|
|
+
|
|
+use strict;
|
|
+our @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] };
|
|
-
|
|
-
|
|
+ q{eq} => sub { $_[0]->{string} eq $_[1] },
|
|
+ q{==} => sub { $_[0]->{num} == $_[1] };
|
|
|
|
package Overloaded::Ify;
|
|
-use vars qw(@ISA);
|
|
-@ISA = qw(Overloaded);
|
|
+
|
|
+use strict;
|
|
+our @ISA = qw(Overloaded);
|
|
|
|
use overload
|
|
- q{""} => sub { $_[0]->{string} },
|
|
- q{0+} => sub { $_[0]->{num} };
|
|
+ q{""} => sub { $_[0]->{string} },
|
|
+ q{0+} => sub { $_[0]->{num} };
|
|
|
|
-1;
|
|
\ No newline at end of file
|
|
+1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/SigDie.pm perl-5.10.0/lib/Test/Simple/t/lib/SigDie.pm
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/lib/SigDie.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/lib/SigDie.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,8 @@
|
|
+package SigDie;
|
|
+
|
|
+use strict;
|
|
+
|
|
+our $DIE;
|
|
+$SIG{__DIE__} = sub { $DIE = $@ };
|
|
+
|
|
+1;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/maybe_regex.t perl-5.10.0/lib/Test/Simple/t/maybe_regex.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/maybe_regex.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/maybe_regex.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -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' );
|
|
}
|
|
|
|
{
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/missing.t perl-5.10.0/lib/Test/Simple/t/missing.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/missing.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/missing.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -33,19 +33,23 @@
|
|
#line 30
|
|
ok(1, 'Foo');
|
|
ok(0, 'Bar');
|
|
+ok(1, '1 2 3');
|
|
|
|
END {
|
|
My::Test::is($$out, <<OUT);
|
|
1..5
|
|
ok 1 - Foo
|
|
not ok 2 - Bar
|
|
+ok 3 - 1 2 3
|
|
OUT
|
|
|
|
My::Test::is($$err, <<ERR);
|
|
# Failed test 'Bar'
|
|
# at $0 line 31.
|
|
-# Looks like you planned 5 tests but only ran 2.
|
|
-# Looks like you failed 1 test of 2 run.
|
|
+# You named your test '1 2 3'. You shouldn't use numbers for your test names.
|
|
+# Very confusing.
|
|
+# Looks like you planned 5 tests but ran 3.
|
|
+# Looks like you failed 1 test of 3 run.
|
|
ERR
|
|
|
|
exit 0;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/More.t perl-5.10.0/lib/Test/Simple/t/More.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/More.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/More.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -3,12 +3,12 @@
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
- @INC = qw(../lib lib);
|
|
+ @INC = qw(../lib lib ../lib/Test/Simple/t/lib);
|
|
}
|
|
}
|
|
|
|
use lib 't/lib';
|
|
-use Test::More tests => 52;
|
|
+use Test::More tests => 53;
|
|
|
|
# Make sure we don't mess with $@ or $!. Test at bottom.
|
|
my $Err = "this should not be touched";
|
|
@@ -47,6 +47,11 @@
|
|
isa_ok(bless([], "Foo"), "Foo");
|
|
isa_ok([], 'ARRAY');
|
|
isa_ok(\42, 'SCALAR');
|
|
+{
|
|
+ local %Bar::;
|
|
+ local @Foo::ISA = 'Bar';
|
|
+ isa_ok( "Foo", "Bar" );
|
|
+}
|
|
|
|
|
|
# can_ok() & isa_ok should call can() & isa() on the given object, not
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/new_ok.t perl-5.10.0/lib/Test/Simple/t/new_ok.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/new_ok.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/new_ok.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,42 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+use strict;
|
|
+
|
|
+use Test::More tests => 13;
|
|
+
|
|
+{
|
|
+ package Bar;
|
|
+
|
|
+ sub new {
|
|
+ my $class = shift;
|
|
+ return bless {@_}, $class;
|
|
+ }
|
|
+
|
|
+
|
|
+ package Foo;
|
|
+ our @ISA = qw(Bar);
|
|
+}
|
|
+
|
|
+{
|
|
+ my $obj = new_ok("Foo");
|
|
+ is_deeply $obj, {};
|
|
+ isa_ok $obj, "Foo";
|
|
+
|
|
+ $obj = new_ok("Bar");
|
|
+ is_deeply $obj, {};
|
|
+ isa_ok $obj, "Bar";
|
|
+
|
|
+ $obj = new_ok("Foo", [this => 42]);
|
|
+ is_deeply $obj, { this => 42 };
|
|
+ isa_ok $obj, "Foo";
|
|
+
|
|
+ $obj = new_ok("Foo", [], "Foo");
|
|
+ is_deeply $obj, {};
|
|
+ isa_ok $obj, "Foo";
|
|
+}
|
|
+
|
|
+# And what if we give it nothing?
|
|
+eval {
|
|
+ new_ok();
|
|
+};
|
|
+is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_plan_at_all.t perl-5.10.0/lib/Test/Simple/t/no_plan_at_all.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/no_plan_at_all.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/no_plan_at_all.t 2009-08-26 06:14:44.000000000 +0200
|
|
@@ -0,0 +1,35 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = qw(../lib lib ../lib/Test/Simple/t/lib);
|
|
+ }
|
|
+}
|
|
+
|
|
+# Test what happens when no plan is delcared and done_testing() is not seen
|
|
+
|
|
+use strict;
|
|
+use lib 't/lib';
|
|
+
|
|
+use Test::Builder;
|
|
+use Test::Builder::NoOutput;
|
|
+
|
|
+my $Test = Test::Builder->new;
|
|
+$Test->level(0);
|
|
+$Test->plan( tests => 1 );
|
|
+
|
|
+my $tb = Test::Builder::NoOutput->create;
|
|
+
|
|
+{
|
|
+ $tb->level(0);
|
|
+ $tb->ok(1, "just a test");
|
|
+ $tb->ok(1, " and another");
|
|
+ $tb->_ending;
|
|
+}
|
|
+
|
|
+$Test->is_eq($tb->read, <<'END', "proper behavior when no plan is seen");
|
|
+ok 1 - just a test
|
|
+ok 2 - and another
|
|
+# Tests were run but no plan was declared and done_testing() was not seen.
|
|
+END
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_plan.t perl-5.10.0/lib/Test/Simple/t/no_plan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/no_plan.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/no_plan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -10,19 +10,24 @@
|
|
}
|
|
}
|
|
|
|
-use Test::More tests => 6;
|
|
+use Test::More tests => 7;
|
|
|
|
my $tb = Test::Builder->create;
|
|
-$tb->level(0);
|
|
|
|
-#line 19
|
|
+#line 20
|
|
ok !eval { $tb->plan(tests => undef) };
|
|
-is($@, "Got an undefined number of tests at $0 line 19.\n");
|
|
+is($@, "Got an undefined number of tests at $0 line 20.\n");
|
|
|
|
-#line 23
|
|
+#line 24
|
|
ok !eval { $tb->plan(tests => 0) };
|
|
-is($@, "You said to run 0 tests at $0 line 23.\n");
|
|
+is($@, "You said to run 0 tests at $0 line 24.\n");
|
|
|
|
-#line 27
|
|
-ok !eval { $tb->ok(1) };
|
|
-is( $@, "You tried to run a test without a plan at $0 line 27.\n");
|
|
+{
|
|
+ my $warning = '';
|
|
+ local $SIG{__WARN__} = sub { $warning .= join '', @_ };
|
|
+
|
|
+#line 31
|
|
+ ok $tb->plan(no_plan => 1);
|
|
+ is( $warning, "no_plan takes no arguments at $0 line 31.\n" );
|
|
+ is $tb->has_plan, 'no_plan';
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_tests.t perl-5.10.0/lib/Test/Simple/t/no_tests.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/no_tests.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/no_tests.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,44 @@
|
|
+#!perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = '../lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+# Can't use Test.pm, that's a 5.005 thing.
|
|
+package My::Test;
|
|
+
|
|
+# This has to be a require or else the END block below runs before
|
|
+# Test::Builder's own and the ending diagnostics don't come out right.
|
|
+require Test::Builder;
|
|
+my $TB = Test::Builder->create;
|
|
+$TB->plan(tests => 3);
|
|
+
|
|
+
|
|
+package main;
|
|
+
|
|
+require Test::Simple;
|
|
+
|
|
+chdir 't';
|
|
+push @INC, '../t/lib/';
|
|
+require Test::Simple::Catch;
|
|
+my($out, $err) = Test::Simple::Catch::caught();
|
|
+local $ENV{HARNESS_ACTIVE} = 0;
|
|
+
|
|
+Test::Simple->import(tests => 1);
|
|
+
|
|
+END {
|
|
+ $TB->is_eq($out->read, <<OUT);
|
|
+1..1
|
|
+OUT
|
|
+
|
|
+ $TB->is_eq($err->read, <<ERR);
|
|
+# No tests run!
|
|
+ERR
|
|
+
|
|
+ $TB->is_eq($?, 255, "exit code");
|
|
+
|
|
+ exit grep { !$_ } $TB->summary;
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/note.t perl-5.10.0/lib/Test/Simple/t/note.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/note.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/note.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,30 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = ('../lib', 'lib');
|
|
+ }
|
|
+ else {
|
|
+ unshift @INC, 't/lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+use strict;
|
|
+use warnings;
|
|
+
|
|
+use Test::Builder::NoOutput;
|
|
+
|
|
+use Test::More tests => 2;
|
|
+
|
|
+{
|
|
+ my $tb = Test::Builder::NoOutput->create;
|
|
+
|
|
+ $tb->note("foo");
|
|
+
|
|
+ $tb->reset_outputs;
|
|
+
|
|
+ is $tb->read('out'), "# foo\n";
|
|
+ is $tb->read('err'), '';
|
|
+}
|
|
+
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/output.t perl-5.10.0/lib/Test/Simple/t/output.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/output.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/output.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,5 +1,7 @@
|
|
#!perl -w
|
|
|
|
+use strict;
|
|
+
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
@@ -11,76 +13,91 @@
|
|
}
|
|
chdir 't';
|
|
|
|
+use Test::Builder;
|
|
|
|
-# Can't use Test.pm, that's a 5.005 thing.
|
|
-print "1..4\n";
|
|
+# The real Test::Builder
|
|
+my $Test = Test::Builder->new;
|
|
+$Test->plan( tests => 6 );
|
|
|
|
-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;
|
|
-}
|
|
-
|
|
-use TieOut;
|
|
-use Test::Builder;
|
|
-my $Test = Test::Builder->new();
|
|
+# The one we're going to test.
|
|
+my $tb = Test::Builder->create();
|
|
|
|
-my $result;
|
|
my $tmpfile = 'foo.tmp';
|
|
-my $out = $Test->output($tmpfile);
|
|
END { 1 while unlink($tmpfile) }
|
|
|
|
-ok( defined $out );
|
|
+# Test output to a file
|
|
+{
|
|
+ my $out = $tb->output($tmpfile);
|
|
+ $Test->ok( defined $out );
|
|
+
|
|
+ print $out "hi!\n";
|
|
+ close *$out;
|
|
+
|
|
+ undef $out;
|
|
+ open(IN, $tmpfile) or die $!;
|
|
+ chomp(my $line = <IN>);
|
|
+ close IN;
|
|
+
|
|
+ $Test->is_eq($line, 'hi!');
|
|
+}
|
|
|
|
-print $out "hi!\n";
|
|
-close *$out;
|
|
|
|
-undef $out;
|
|
-open(IN, $tmpfile) or die $!;
|
|
-chomp(my $line = <IN>);
|
|
-close IN;
|
|
-
|
|
-ok($line eq 'hi!');
|
|
-
|
|
-open(FOO, ">>$tmpfile") or die $!;
|
|
-$out = $Test->output(\*FOO);
|
|
-$old = select *$out;
|
|
-print "Hello!\n";
|
|
-close *$out;
|
|
-undef $out;
|
|
-select $old;
|
|
-open(IN, $tmpfile) or die $!;
|
|
-my @lines = <IN>;
|
|
-close IN;
|
|
+# Test output to a filehandle
|
|
+{
|
|
+ open(FOO, ">>$tmpfile") or die $!;
|
|
+ my $out = $tb->output(\*FOO);
|
|
+ my $old = select *$out;
|
|
+ print "Hello!\n";
|
|
+ close *$out;
|
|
+ undef $out;
|
|
+ select $old;
|
|
+ open(IN, $tmpfile) or die $!;
|
|
+ my @lines = <IN>;
|
|
+ close IN;
|
|
|
|
-ok($lines[1] =~ /Hello!/);
|
|
+ $Test->like($lines[1], qr/Hello!/);
|
|
+}
|
|
|
|
|
|
+# Test output to a scalar ref
|
|
+{
|
|
+ my $scalar = '';
|
|
+ my $out = $tb->output(\$scalar);
|
|
+
|
|
+ print $out "Hey hey hey!\n";
|
|
+ $Test->is_eq($scalar, "Hey hey hey!\n");
|
|
+}
|
|
+
|
|
+
|
|
+# Test we can output to the same scalar ref
|
|
+{
|
|
+ my $scalar = '';
|
|
+ my $out = $tb->output(\$scalar);
|
|
+ my $err = $tb->failure_output(\$scalar);
|
|
+
|
|
+ print $out "To output ";
|
|
+ print $err "and beyond!";
|
|
+
|
|
+ $Test->is_eq($scalar, "To output and beyond!", "One scalar, two filehandles");
|
|
+}
|
|
+
|
|
|
|
# Ensure stray newline in name escaping works.
|
|
-$out = tie *FAKEOUT, 'TieOut';
|
|
-$Test->output(\*FAKEOUT);
|
|
-$Test->exported_to(__PACKAGE__);
|
|
-$Test->no_ending(1);
|
|
-$Test->plan(tests => 5);
|
|
-
|
|
-$Test->ok(1, "ok");
|
|
-$Test->ok(1, "ok\n");
|
|
-$Test->ok(1, "ok, like\nok");
|
|
-$Test->skip("wibble\nmoof");
|
|
-$Test->todo_skip("todo\nskip\n");
|
|
+{
|
|
+ my $fakeout = '';
|
|
+ my $out = $tb->output(\$fakeout);
|
|
+ $tb->exported_to(__PACKAGE__);
|
|
+ $tb->no_ending(1);
|
|
+ $tb->plan(tests => 5);
|
|
+
|
|
+ $tb->ok(1, "ok");
|
|
+ $tb->ok(1, "ok\n");
|
|
+ $tb->ok(1, "ok, like\nok");
|
|
+ $tb->skip("wibble\nmoof");
|
|
+ $tb->todo_skip("todo\nskip\n");
|
|
|
|
-my $output = $out->read;
|
|
-ok( $output eq <<OUTPUT ) || print STDERR $output;
|
|
+ $Test->is_eq( $fakeout, <<OUTPUT ) || print STDERR $fakeout;
|
|
1..5
|
|
ok 1 - ok
|
|
ok 2 - ok
|
|
@@ -93,3 +110,4 @@
|
|
# skip
|
|
#
|
|
OUTPUT
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/overload.t perl-5.10.0/lib/Test/Simple/t/overload.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/overload.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/overload.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -11,27 +11,26 @@
|
|
}
|
|
|
|
use strict;
|
|
-use Test::More;
|
|
-
|
|
-BEGIN {
|
|
- if( !eval "require overload" ) {
|
|
- plan skip_all => "needs overload.pm";
|
|
- }
|
|
- else {
|
|
- plan tests => 13;
|
|
- }
|
|
-}
|
|
+use Test::More tests => 19;
|
|
|
|
|
|
package Overloaded;
|
|
|
|
use overload
|
|
- q{""} => sub { $_[0]->{string} },
|
|
- q{0+} => sub { $_[0]->{num} };
|
|
+ q{eq} => sub { $_[0]->{string} eq $_[1] },
|
|
+ q{==} => sub { $_[0]->{num} == $_[1] },
|
|
+ q{""} => sub { $_[0]->{stringify}++; $_[0]->{string} },
|
|
+ q{0+} => sub { $_[0]->{numify}++; $_[0]->{num} }
|
|
+;
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
- bless { string => shift, num => shift }, $class;
|
|
+ bless {
|
|
+ string => shift,
|
|
+ num => shift,
|
|
+ stringify => 0,
|
|
+ numify => 0,
|
|
+ }, $class;
|
|
}
|
|
|
|
|
|
@@ -46,9 +45,11 @@
|
|
my $obj = Overloaded->new('foo', 42);
|
|
isa_ok $obj, 'Overloaded';
|
|
|
|
-is $obj, 'foo', 'is() with string overloading';
|
|
-cmp_ok $obj, 'eq', 'foo', 'cmp_ok() ...';
|
|
-cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading';
|
|
+cmp_ok $obj, 'eq', 'foo', 'cmp_ok() eq';
|
|
+is $obj->{stringify}, 0, ' does not stringify';
|
|
+is $obj, 'foo', 'is() with string overloading';
|
|
+cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading';
|
|
+is $obj->{numify}, 0, ' does not numify';
|
|
|
|
is_deeply [$obj], ['foo'], 'is_deeply with string overloading';
|
|
ok eq_array([$obj], ['foo']), 'eq_array ...';
|
|
@@ -72,3 +73,14 @@
|
|
{'TestPackage' => 'TestPackage'});
|
|
::is_deeply('TestPackage', 'TestPackage');
|
|
}
|
|
+
|
|
+
|
|
+# Make sure 0 isn't a special case. [rt.cpan.org 41109]
|
|
+{
|
|
+ my $obj = Overloaded->new('0', 42);
|
|
+ isa_ok $obj, 'Overloaded';
|
|
+
|
|
+ cmp_ok $obj, 'eq', '0', 'cmp_ok() eq';
|
|
+ is $obj->{stringify}, 0, ' does not stringify';
|
|
+ is $obj, '0', 'is() with string overloading';
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/overload_threads.t perl-5.10.0/lib/Test/Simple/t/overload_threads.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/overload_threads.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/overload_threads.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -17,16 +17,7 @@
|
|
eval { require threads; 'threads'->import; 1; };
|
|
}
|
|
|
|
-use Test::More;
|
|
-
|
|
-BEGIN {
|
|
- if( !eval "require overload" ) {
|
|
- plan skip_all => "needs overload.pm";
|
|
- }
|
|
- else {
|
|
- plan tests => 5;
|
|
- }
|
|
-}
|
|
+use Test::More tests => 5;
|
|
|
|
|
|
package Overloaded;
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/plan_bad.t perl-5.10.0/lib/Test/Simple/t/plan_bad.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/plan_bad.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/plan_bad.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -8,7 +8,7 @@
|
|
}
|
|
|
|
|
|
-use Test::More tests => 10;
|
|
+use Test::More tests => 12;
|
|
use Test::Builder;
|
|
my $tb = Test::Builder->create;
|
|
$tb->level(0);
|
|
@@ -21,6 +21,9 @@
|
|
ok !eval { $tb->plan( tests => @foo ) };
|
|
is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1;
|
|
|
|
+ok !eval { $tb->plan( tests => 9.99 ) };
|
|
+is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1;
|
|
+
|
|
#line 25
|
|
ok !eval { $tb->plan( tests => -1 ) };
|
|
is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n";
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/plan_is_noplan.t perl-5.10.0/lib/Test/Simple/t/plan_is_noplan.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/plan_is_noplan.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/plan_is_noplan.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,3 +1,5 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
@@ -8,47 +10,23 @@
|
|
}
|
|
}
|
|
|
|
-# Can't use Test.pm, that's a 5.005 thing.
|
|
-package My::Test;
|
|
-
|
|
-print "1..2\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++;
|
|
-}
|
|
-
|
|
+use strict;
|
|
|
|
-package main;
|
|
+use Test::More tests => 1;
|
|
|
|
-require Test::Simple;
|
|
+use Test::Builder::NoOutput;
|
|
|
|
-require Test::Simple::Catch;
|
|
-my($out, $err) = Test::Simple::Catch::caught();
|
|
+{
|
|
+ my $tb = Test::Builder::NoOutput->create;
|
|
|
|
+ $tb->plan('no_plan');
|
|
|
|
-Test::Simple->import('no_plan');
|
|
+ $tb->ok(1, 'foo');
|
|
+ $tb->_ending;
|
|
|
|
-ok(1, 'foo');
|
|
-
|
|
-
|
|
-END {
|
|
- My::Test::ok($$out eq <<OUT);
|
|
+ is($tb->read, <<OUT);
|
|
ok 1 - foo
|
|
1..1
|
|
OUT
|
|
-
|
|
- My::Test::ok($$err eq <<ERR);
|
|
-ERR
|
|
-
|
|
- # Prevent Test::Simple from exiting with non zero
|
|
- exit 0;
|
|
}
|
|
+
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/reset_outputs.t perl-5.10.0/lib/Test/Simple/t/reset_outputs.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/reset_outputs.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/reset_outputs.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,35 @@
|
|
+#!perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = ('../lib', 'lib');
|
|
+ }
|
|
+ else {
|
|
+ unshift @INC, 't/lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+use Test::Builder;
|
|
+use Test::More 'no_plan';
|
|
+
|
|
+{
|
|
+ my $tb = Test::Builder->create();
|
|
+
|
|
+ # Store the original output filehandles and change them all.
|
|
+ my %original_outputs;
|
|
+
|
|
+ open my $fh, ">", "dummy_file.tmp";
|
|
+ END { 1 while unlink "dummy_file.tmp"; }
|
|
+ for my $method (qw(output failure_output todo_output)) {
|
|
+ $original_outputs{$method} = $tb->$method();
|
|
+ $tb->$method($fh);
|
|
+ is $tb->$method(), $fh;
|
|
+ }
|
|
+
|
|
+ $tb->reset_outputs;
|
|
+
|
|
+ for my $method (qw(output failure_output todo_output)) {
|
|
+ is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method";
|
|
+ }
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/reset.t perl-5.10.0/lib/Test/Simple/t/reset.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/reset.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/reset.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -15,19 +15,23 @@
|
|
|
|
|
|
use Test::Builder;
|
|
-my $tb = Test::Builder->new;
|
|
-$tb->plan(tests => 14);
|
|
-$tb->level(0);
|
|
+my $Test = Test::Builder->new;
|
|
+my $tb = Test::Builder->create;
|
|
+
|
|
+# We'll need this later to know the outputs were reset
|
|
+my %Original_Output;
|
|
+$Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output);
|
|
|
|
# Alter the state of Test::Builder as much as possible.
|
|
-$tb->ok(1, "Running a test to alter TB's state");
|
|
+my $output = '';
|
|
+$tb->output(\$output);
|
|
+$tb->failure_output(\$output);
|
|
+$tb->todo_output(\$output);
|
|
|
|
-my $tmpfile = 'foo.tmp';
|
|
+$tb->plan(tests => 14);
|
|
+$tb->level(0);
|
|
|
|
-$tb->output($tmpfile);
|
|
-$tb->failure_output($tmpfile);
|
|
-$tb->todo_output($tmpfile);
|
|
-END { 1 while unlink $tmpfile }
|
|
+$tb->ok(1, "Running a test to alter TB's state");
|
|
|
|
# This won't print since we just sent output off to oblivion.
|
|
$tb->ok(0, "And a failure for fun");
|
|
@@ -44,41 +48,26 @@
|
|
# Now reset it.
|
|
$tb->reset;
|
|
|
|
-my $test_num = 2; # since we already printed 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;
|
|
-}
|
|
-
|
|
-
|
|
-ok( !defined $tb->exported_to, 'exported_to' );
|
|
-ok( $tb->expected_tests == 0, 'expected_tests' );
|
|
-ok( $tb->level == 1, 'level' );
|
|
-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,
|
|
- 'output' );
|
|
-ok( fileno $tb->failure_output == fileno *Test::Builder::TESTERR,
|
|
- 'failure_output' );
|
|
-ok( fileno $tb->todo_output == fileno *Test::Builder::TESTOUT,
|
|
- 'todo_output' );
|
|
-ok( $tb->current_test == 0, 'current_test' );
|
|
-ok( $tb->summary == 0, 'summary' );
|
|
-ok( $tb->details == 0, 'details' );
|
|
|
|
-$tb->no_ending(1);
|
|
-$tb->no_header(1);
|
|
-$tb->plan(tests => 14);
|
|
-$tb->current_test(13);
|
|
+$Test->ok( !defined $tb->exported_to, 'exported_to' );
|
|
+$Test->is_eq( $tb->expected_tests, 0, 'expected_tests' );
|
|
+$Test->is_eq( $tb->level, 1, 'level' );
|
|
+$Test->is_eq( $tb->use_numbers, 1, 'use_numbers' );
|
|
+$Test->is_eq( $tb->no_header, 0, 'no_header' );
|
|
+$Test->is_eq( $tb->no_ending, 0, 'no_ending' );
|
|
+$Test->is_eq( $tb->current_test, 0, 'current_test' );
|
|
+$Test->is_eq( scalar $tb->summary, 0, 'summary' );
|
|
+$Test->is_eq( scalar $tb->details, 0, 'details' );
|
|
+$Test->is_eq( fileno $tb->output,
|
|
+ fileno $Original_Output{output}, 'output' );
|
|
+$Test->is_eq( fileno $tb->failure_output,
|
|
+ fileno $Original_Output{failure_output}, 'failure_output' );
|
|
+$Test->is_eq( fileno $tb->todo_output,
|
|
+ fileno $Original_Output{todo_output}, 'todo_output' );
|
|
+
|
|
+$tb->current_test(12);
|
|
$tb->level(0);
|
|
$tb->ok(1, 'final test to make sure output was reset');
|
|
+
|
|
+$Test->current_test(13);
|
|
+$Test->done_testing(13);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/skipall.t perl-5.10.0/lib/Test/Simple/t/skipall.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/skipall.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/skipall.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,3 +1,5 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
@@ -10,35 +12,22 @@
|
|
|
|
use strict;
|
|
|
|
-# Can't use Test.pm, that's a 5.005 thing.
|
|
-package My::Test;
|
|
-
|
|
-print "1..2\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++;
|
|
-}
|
|
+use Test::More;
|
|
|
|
+my $Test = Test::Builder->create;
|
|
+$Test->plan(tests => 2);
|
|
|
|
-package main;
|
|
-require Test::More;
|
|
-
|
|
-require Test::Simple::Catch;
|
|
-my($out, $err) = Test::Simple::Catch::caught();
|
|
-
|
|
-Test::More->import('skip_all');
|
|
+my $out = '';
|
|
+my $err = '';
|
|
+{
|
|
+ my $tb = Test::More->builder;
|
|
+ $tb->output(\$out);
|
|
+ $tb->failure_output(\$err);
|
|
|
|
+ plan 'skip_all';
|
|
+}
|
|
|
|
END {
|
|
- My::Test::ok($$out eq "1..0\n");
|
|
- My::Test::ok($$err eq "");
|
|
+ $Test->is_eq($out, "1..0 # SKIP\n");
|
|
+ $Test->is_eq($err, "");
|
|
}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/skip.t perl-5.10.0/lib/Test/Simple/t/skip.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/skip.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/skip.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -94,5 +94,5 @@
|
|
pass "This does not run";
|
|
}
|
|
|
|
- like $warning, '/^skip\(\) was passed a non-numeric number of tests/';
|
|
+ like $warning, qr/^skip\(\) was passed a non-numeric number of tests/;
|
|
}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t perl-5.10.0/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -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()'
|
|
+);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/thread_taint.t perl-5.10.0/lib/Test/Simple/t/thread_taint.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/thread_taint.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/thread_taint.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -2,4 +2,4 @@
|
|
|
|
use Test::More tests => 1;
|
|
|
|
-ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' );
|
|
\ No newline at end of file
|
|
+ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' );
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/todo.t perl-5.10.0/lib/Test/Simple/t/todo.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/todo.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/todo.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -9,7 +9,7 @@
|
|
|
|
use Test::More;
|
|
|
|
-plan tests => 18;
|
|
+plan tests => 36;
|
|
|
|
|
|
$Why = 'Just testing the todo interface.';
|
|
@@ -42,7 +42,7 @@
|
|
|
|
ok( 'this' eq 'that', 'ok' );
|
|
|
|
- like( 'this', '/that/', 'like' );
|
|
+ like( 'this', qr/that/, 'like' );
|
|
is( 'this', 'that', 'is' );
|
|
isnt( 'this', 'this', 'isnt' );
|
|
|
|
@@ -69,11 +69,89 @@
|
|
# perl gets the line number a little wrong on the first
|
|
# statement inside a block.
|
|
1 == 1;
|
|
-#line 82
|
|
+#line 74
|
|
todo_skip "Just testing todo_skip";
|
|
fail("So very failed");
|
|
}
|
|
is( $warning, "todo_skip() needs to know \$how_many tests are in the ".
|
|
- "block at $0 line 82\n",
|
|
+ "block at $0 line 74\n",
|
|
'todo_skip without $how_many warning' );
|
|
}
|
|
+
|
|
+my $builder = Test::More->builder;
|
|
+my $exported_to = $builder->exported_to;
|
|
+TODO: {
|
|
+ $builder->exported_to("Wibble");
|
|
+
|
|
+ local $TODO = "testing \$TODO with an incorrect exported_to()";
|
|
+
|
|
+ fail("Just testing todo");
|
|
+}
|
|
+
|
|
+$builder->exported_to($exported_to);
|
|
+
|
|
+$builder->todo_start('Expected failures');
|
|
+fail('Testing todo_start()');
|
|
+ok 0, 'Testing todo_start() with more than one failure';
|
|
+$is_todo = $builder->todo;
|
|
+$builder->todo_end;
|
|
+is $is_todo, 'Expected failures',
|
|
+ 'todo_start should have the correct TODO message';
|
|
+ok 1, 'todo_end() should not leak TODO behavior';
|
|
+
|
|
+my @nested_todo;
|
|
+my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' );
|
|
+TODO: {
|
|
+ local $TODO = 'Nesting TODO';
|
|
+ fail('fail 1');
|
|
+
|
|
+ $builder->todo_start($level1);
|
|
+ fail('fail 2');
|
|
+
|
|
+ push @nested_todo => $builder->todo;
|
|
+ $builder->todo_start($level2);
|
|
+ fail('fail 3');
|
|
+
|
|
+ push @nested_todo => $builder->todo;
|
|
+ $builder->todo_end;
|
|
+ fail('fail 4');
|
|
+
|
|
+ push @nested_todo => $builder->todo;
|
|
+ $builder->todo_end;
|
|
+ $is_todo = $builder->todo;
|
|
+ fail('fail 4');
|
|
+}
|
|
+is_deeply \@nested_todo, [ $level1, $level2, $level1 ],
|
|
+ 'Nested TODO message should be correct';
|
|
+is $is_todo, 'Nesting TODO',
|
|
+ '... and original TODO message should be correct';
|
|
+
|
|
+{
|
|
+ $builder->todo_start;
|
|
+ fail("testing todo_start() with no message");
|
|
+ my $reason = $builder->todo;
|
|
+ my $in_todo = $builder->in_todo;
|
|
+ $builder->todo_end;
|
|
+
|
|
+ is $reason, '', " todo() reports no reason";
|
|
+ ok $in_todo, " but we're in_todo()";
|
|
+}
|
|
+
|
|
+eval {
|
|
+ $builder->todo_end;
|
|
+};
|
|
+is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2;
|
|
+
|
|
+
|
|
+{
|
|
+ my($reason, $in_todo);
|
|
+
|
|
+ TODO: {
|
|
+ local $TODO = '';
|
|
+ $reason = $builder->todo;
|
|
+ $in_todo = $builder->in_todo;
|
|
+ }
|
|
+
|
|
+ is $reason, '';
|
|
+ ok !$in_todo, '$TODO = "" is not considered TODO';
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/try.t perl-5.10.0/lib/Test/Simple/t/try.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/try.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/try.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -17,19 +17,26 @@
|
|
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
|
|
+# Test that _try() has no effect on $@ and $! and is not effected by
|
|
+# __DIE__
|
|
+{
|
|
+ local $SIG{__DIE__} = sub { fail("DIE handler called: @_") };
|
|
+ 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, "Foo\n"];
|
|
+
|
|
+ is $@, 42;
|
|
+ cmp_ok $!, '==', 23;
|
|
+}
|
|
+
|
|
+ok !eval {
|
|
+ $tb->_try(sub { die "Died\n" }, die_on_fail => 1);
|
|
+};
|
|
+is $@, "Died\n";
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/undef.t perl-5.10.0/lib/Test/Simple/t/undef.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/undef.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/undef.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -11,8 +11,7 @@
|
|
}
|
|
|
|
use strict;
|
|
-use Test::More tests => 18;
|
|
-use TieOut;
|
|
+use Test::More tests => 21;
|
|
|
|
BEGIN { $^W = 1; }
|
|
|
|
@@ -31,7 +30,7 @@
|
|
}
|
|
|
|
sub warnings_like {
|
|
- $TB->like($warnings, "/$_[0]/");
|
|
+ $TB->like($warnings, $_[0]);
|
|
$warnings = '';
|
|
}
|
|
|
|
@@ -48,9 +47,12 @@
|
|
isnt( undef, '', 'undef isnt an empty string' );
|
|
isnt( undef, 0, 'undef isnt zero' );
|
|
|
|
+Test::More->builder->is_num(undef, undef, 'is_num()');
|
|
+Test::More->builder->isnt_num(23, undef, 'isnt_num()');
|
|
+
|
|
#line 45
|
|
-like( undef, '/.*/', 'undef is like anything' );
|
|
-warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n");
|
|
+like( undef, qr/.*/, 'undef is like anything' );
|
|
+warnings_like(qr/Use of uninitialized value.* at $Filename line 45\.\n/);
|
|
|
|
eq_array( [undef, undef], [undef, 23] );
|
|
no_warnings;
|
|
@@ -70,23 +72,27 @@
|
|
|
|
#line 64
|
|
cmp_ok( undef, '<=', 2, ' undef <= 2' );
|
|
-warnings_like("Use of uninitialized value.* at $Filename line 64\\.\n");
|
|
+warnings_like(qr/Use of uninitialized value.* at cmp_ok \[from $Filename line 64\] line 1\.\n/);
|
|
|
|
|
|
|
|
my $tb = Test::More->builder;
|
|
|
|
-use TieOut;
|
|
-my $caught = tie *CATCH, 'TieOut';
|
|
-my $old_fail = $tb->failure_output;
|
|
-$tb->failure_output(\*CATCH);
|
|
+my $err;
|
|
+$tb->failure_output(\$err);
|
|
diag(undef);
|
|
-$tb->failure_output($old_fail);
|
|
+$tb->reset_outputs;
|
|
|
|
-is( $caught->read, "# undef\n" );
|
|
+is( $err, "# undef\n" );
|
|
no_warnings;
|
|
|
|
|
|
$tb->maybe_regex(undef);
|
|
-is( $caught->read, '' );
|
|
no_warnings;
|
|
+
|
|
+
|
|
+# test-more.googlecode.com #42
|
|
+{
|
|
+ is_deeply([ undef ], [ undef ]);
|
|
+ no_warnings;
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/use_ok.t perl-5.10.0/lib/Test/Simple/t/use_ok.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/use_ok.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/use_ok.t 2009-08-26 06:16:36.000000000 +0200
|
|
@@ -3,14 +3,14 @@
|
|
BEGIN {
|
|
if( $ENV{PERL_CORE} ) {
|
|
chdir 't';
|
|
- @INC = ('../lib', 'lib');
|
|
+ @INC = qw(../lib lib ../lib/Test/Simple/t/lib);
|
|
}
|
|
else {
|
|
unshift @INC, 't/lib';
|
|
}
|
|
}
|
|
|
|
-use Test::More tests => 13;
|
|
+use Test::More tests => 15;
|
|
|
|
# Using Symbol because it's core and exports lots of stuff.
|
|
{
|
|
@@ -58,3 +58,10 @@
|
|
};
|
|
::use_ok("Test::More", 0.47);
|
|
}
|
|
+
|
|
+{
|
|
+ package Foo::eight;
|
|
+ local $SIG{__DIE__};
|
|
+ ::use_ok("SigDie");
|
|
+ ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved');
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/utf8.t perl-5.10.0/lib/Test/Simple/t/utf8.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/utf8.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/utf8.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,69 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+BEGIN {
|
|
+ if( $ENV{PERL_CORE} ) {
|
|
+ chdir 't';
|
|
+ @INC = '../lib';
|
|
+ }
|
|
+}
|
|
+
|
|
+use strict;
|
|
+use warnings;
|
|
+
|
|
+use Test::More skip_all => 'Not yet implemented';
|
|
+
|
|
+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;
|
|
+
|
|
+if( !$have_perlio ) {
|
|
+ plan skip_all => "Don't have PerlIO";
|
|
+}
|
|
+else {
|
|
+ plan tests => 5;
|
|
+}
|
|
+
|
|
+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 { map { $_ => 1 } PerlIO::get_layers($dest) },
|
|
+ { map { $_ => 1 } 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, [] );
|
|
+}
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple/t/versions.t perl-5.10.0/lib/Test/Simple/t/versions.t
|
|
--- perl-5.10.0.orig/lib/Test/Simple/t/versions.t 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple/t/versions.t 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,21 @@
|
|
+#!/usr/bin/perl -w
|
|
+
|
|
+# Make sure all the modules have the same version
|
|
+#
|
|
+# TBT has its own version system.
|
|
+
|
|
+use strict;
|
|
+use Test::More;
|
|
+
|
|
+require Test::Builder;
|
|
+require Test::Builder::Module;
|
|
+require Test::Simple;
|
|
+
|
|
+my $dist_version = $Test::More::VERSION;
|
|
+
|
|
+like( $dist_version, qr/^ \d+ \. \d+ $/x );
|
|
+is( $dist_version, $Test::Builder::VERSION, 'Test::Builder' );
|
|
+is( $dist_version, $Test::Builder::Module::VERSION, 'TB::Module' );
|
|
+is( $dist_version, $Test::Simple::VERSION, 'Test::Simple' );
|
|
+
|
|
+done_testing(4);
|
|
diff -urN perl-5.10.0.orig/lib/Test/Simple.pm perl-5.10.0/lib/Test/Simple.pm
|
|
--- perl-5.10.0.orig/lib/Test/Simple.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/Test/Simple.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -2,18 +2,17 @@
|
|
|
|
use 5.004;
|
|
|
|
-use strict 'vars';
|
|
-use vars qw($VERSION @ISA @EXPORT);
|
|
-$VERSION = '0.72';
|
|
-$VERSION = eval $VERSION; # make the alpha version come out as a number
|
|
+use strict;
|
|
+
|
|
+our $VERSION = '0.92';
|
|
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
|
|
|
|
use Test::Builder::Module;
|
|
-@ISA = qw(Test::Builder::Module);
|
|
-@EXPORT = qw(ok);
|
|
+our @ISA = qw(Test::Builder::Module);
|
|
+our @EXPORT = qw(ok);
|
|
|
|
my $CLASS = __PACKAGE__;
|
|
|
|
-
|
|
=head1 NAME
|
|
|
|
Test::Simple - Basic utilities for writing tests.
|
|
@@ -77,11 +76,10 @@
|
|
|
|
=cut
|
|
|
|
-sub ok ($;$) {
|
|
- $CLASS->builder->ok(@_);
|
|
+sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
|
|
+ return $CLASS->builder->ok(@_);
|
|
}
|
|
|
|
-
|
|
=back
|
|
|
|
Test::Simple will start by printing number of tests run in the form
|
|
@@ -191,24 +189,10 @@
|
|
(i.e. you can just use Test::More instead of Test::Simple in your
|
|
programs and things will still work).
|
|
|
|
-=item L<Test>
|
|
-
|
|
-The original Perl testing module.
|
|
-
|
|
-=item L<Test::Unit>
|
|
-
|
|
-Elaborate unit testing.
|
|
-
|
|
-=item L<Test::Inline>, L<SelfTest>
|
|
-
|
|
-Embed tests in your code!
|
|
-
|
|
-=item L<Test::Harness>
|
|
-
|
|
-Interprets the output of your test program.
|
|
-
|
|
=back
|
|
|
|
+Look in Test::More's SEE ALSO for more testing modules.
|
|
+
|
|
|
|
=head1 AUTHORS
|
|
|
|
@@ -218,7 +202,7 @@
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
-Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
|
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
|
|
--- perl-5.10.0.orig/MANIFEST 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/MANIFEST 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -2626,20 +2626,34 @@
|
|
lib/Test/Simple/Changes Test::Simple changes
|
|
lib/Test/Simple.pm Basic utility for writing tests
|
|
lib/Test/Simple/README Test::Simple README
|
|
+lib/Test/Simple/TODO Test::Simple TODO
|
|
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
|
|
+lib/Test/Simple/t/BEGIN_use_ok.t
|
|
lib/Test/Simple/t/buffer.t Test::Builder buffering test
|
|
lib/Test/Simple/t/Builder.t Test::Builder tests
|
|
+lib/Test/Simple/t/c_flag.t
|
|
lib/Test/Simple/t/carp.t Test::Builder test
|
|
lib/Test/Simple/t/circular_data.t Test::Simple test
|
|
lib/Test/Simple/t/cmp_ok.t Test::More test
|
|
lib/Test/Simple/t/create.t Test::Simple test
|
|
-lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests
|
|
+lib/Test/Simple/t/current_test.t
|
|
+lib/Test/Simple/t/current_test_without_plan.t
|
|
lib/Test/Simple/t/details.t Test::Builder tests
|
|
lib/Test/Simple/t/diag.t Test::More diag() test
|
|
+lib/Test/Simple/t/died.t
|
|
+lib/Test/Simple/t/done_testing_double.t
|
|
+lib/Test/Simple/t/done_testing_plan_mismatch.t
|
|
+lib/Test/Simple/t/done_testing.t
|
|
+lib/Test/Simple/t/done_testing_with_no_plan.t
|
|
+lib/Test/Simple/t/done_testing_with_number.t
|
|
+lib/Test/Simple/t/done_testing_with_plan.t
|
|
+lib/Test/Simple/t/dont_overwrite_die_handler.t
|
|
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/explain.t
|
|
lib/Test/Simple/t/extra_one.t Test::Simple test
|
|
lib/Test/Simple/t/extra.t Test::Simple test
|
|
lib/Test/Simple/t/fail-like.t Test::More test, like() failures
|
|
@@ -2648,6 +2662,7 @@
|
|
lib/Test/Simple/t/fail.t Test::Simple test, test failures
|
|
lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with
|
|
lib/Test/Simple/t/fork.t Test::More fork tests
|
|
+lib/Test/Simple/t/fork_with_new_stdout.t
|
|
lib/Test/Simple/t/harness_active.t Test::Simple test
|
|
lib/Test/Simple/t/has_plan2.t Test::More->plan tests
|
|
lib/Test/Simple/t/has_plan.t Test::Builder->plan tests
|
|
@@ -2661,10 +2676,15 @@
|
|
lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests
|
|
lib/Test/Simple/t/missing.t Test::Simple test, missing tests
|
|
lib/Test/Simple/t/More.t Test::More test, basic stuff
|
|
+lib/Test/Simple/t/new_ok.t
|
|
lib/Test/Simple/t/no_diag.t Test::Simple test
|
|
lib/Test/Simple/t/no_ending.t Test::Builder test, no_ending()
|
|
lib/Test/Simple/t/no_header.t Test::Builder test, no_header()
|
|
lib/Test/Simple/t/no_plan.t Test::Simple test, forgot the plan
|
|
+lib/Test/Simple/t/no_plan_at_all.t
|
|
+lib/Test/Simple/t/no_tests.t
|
|
+lib/Test/Simple/t/note.t
|
|
+lib/Test/Simple/t/reset_outputs.t
|
|
lib/Test/Simple/TODO Test::Simple TODO
|
|
lib/Test/Simple/t/ok_obj.t Test::Builder object tests
|
|
lib/Test/Simple/t/output.t Test::Builder test, output methods
|
|
@@ -2681,6 +2701,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
|
|
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
|
|
@@ -2695,6 +2716,8 @@
|
|
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
|
|
+lib/Test/Simple/t/versions.t
|
|
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
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Builder/NoOutput.pm perl-5.10.0/t/lib/Test/Builder/NoOutput.pm
|
|
--- perl-5.10.0.orig/t/lib/Test/Builder/NoOutput.pm 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Builder/NoOutput.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,122 @@
|
|
+package Test::Builder::NoOutput;
|
|
+
|
|
+use strict;
|
|
+use warnings;
|
|
+
|
|
+use base qw(Test::Builder);
|
|
+
|
|
+
|
|
+=head1 NAME
|
|
+
|
|
+Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing
|
|
+
|
|
+=head1 SYNOPSIS
|
|
+
|
|
+ use Test::Builder::NoOutput;
|
|
+
|
|
+ my $tb = Test::Builder::NoOutput->new;
|
|
+
|
|
+ ...test as normal...
|
|
+
|
|
+ my $output = $tb->read;
|
|
+
|
|
+=head1 DESCRIPTION
|
|
+
|
|
+This is a subclass of Test::Builder which traps all its output.
|
|
+It is mostly useful for testing Test::Builder.
|
|
+
|
|
+=head3 read
|
|
+
|
|
+ my $all_output = $tb->read;
|
|
+ my $output = $tb->read($stream);
|
|
+
|
|
+Returns all the output (including failure and todo output) collected
|
|
+so far. It is destructive, each call to read clears the output
|
|
+buffer.
|
|
+
|
|
+If $stream is given it will return just the output from that stream.
|
|
+$stream's are...
|
|
+
|
|
+ out output()
|
|
+ err failure_output()
|
|
+ todo todo_output()
|
|
+ all all outputs
|
|
+
|
|
+Defaults to 'all'.
|
|
+
|
|
+=cut
|
|
+
|
|
+my $Test = __PACKAGE__->new;
|
|
+
|
|
+sub create {
|
|
+ my $class = shift;
|
|
+ my $self = $class->SUPER::create(@_);
|
|
+
|
|
+ my %outputs = (
|
|
+ all => '',
|
|
+ out => '',
|
|
+ err => '',
|
|
+ todo => '',
|
|
+ );
|
|
+ $self->{_outputs} = \%outputs;
|
|
+
|
|
+ tie *OUT, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out};
|
|
+ tie *ERR, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err};
|
|
+ tie *TODO, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo};
|
|
+
|
|
+ $self->output(*OUT);
|
|
+ $self->failure_output(*ERR);
|
|
+ $self->todo_output(*TODO);
|
|
+
|
|
+ return $self;
|
|
+}
|
|
+
|
|
+sub read {
|
|
+ my $self = shift;
|
|
+ my $stream = @_ ? shift : 'all';
|
|
+
|
|
+ my $out = $self->{_outputs}{$stream};
|
|
+
|
|
+ $self->{_outputs}{$stream} = '';
|
|
+
|
|
+ # Clear all the streams if 'all' is read.
|
|
+ if( $stream eq 'all' ) {
|
|
+ my @keys = keys %{$self->{_outputs}};
|
|
+ $self->{_outputs}{$_} = '' for @keys;
|
|
+ }
|
|
+
|
|
+ return $out;
|
|
+}
|
|
+
|
|
+
|
|
+package Test::Builder::NoOutput::Tee;
|
|
+
|
|
+# A cheap implementation of IO::Tee.
|
|
+
|
|
+sub TIEHANDLE {
|
|
+ my($class, @refs) = @_;
|
|
+
|
|
+ my @fhs;
|
|
+ for my $ref (@refs) {
|
|
+ my $fh = Test::Builder->_new_fh($ref);
|
|
+ push @fhs, $fh;
|
|
+ }
|
|
+
|
|
+ my $self = [@fhs];
|
|
+ return bless $self, $class;
|
|
+}
|
|
+
|
|
+sub PRINT {
|
|
+ my $self = shift;
|
|
+
|
|
+ print $_ @_ for @$self;
|
|
+}
|
|
+
|
|
+sub PRINTF {
|
|
+ my $self = shift;
|
|
+ my $format = shift;
|
|
+
|
|
+ printf $_ @_ for @$self;
|
|
+}
|
|
+
|
|
+1;
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Simple/Catch.pm perl-5.10.0/t/lib/Test/Simple/Catch.pm
|
|
--- perl-5.10.0.orig/t/lib/Test/Simple/Catch.pm 2007-12-18 11:47:08.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Simple/Catch.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,9 +1,11 @@
|
|
# For testing Test::Simple;
|
|
package Test::Simple::Catch;
|
|
|
|
+use strict;
|
|
+
|
|
use Symbol;
|
|
use TieOut;
|
|
-my($out_fh, $err_fh) = (gensym, gensym);
|
|
+my( $out_fh, $err_fh ) = ( gensym, gensym );
|
|
my $out = tie *$out_fh, 'TieOut';
|
|
my $err = tie *$err_fh, 'TieOut';
|
|
|
|
@@ -13,6 +15,6 @@
|
|
$t->failure_output($err_fh);
|
|
$t->todo_output($err_fh);
|
|
|
|
-sub caught { return($out, $err) }
|
|
+sub caught { return( $out, $err ) }
|
|
|
|
1;
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/death.plx
|
|
--- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death.plx 2007-12-18 11:47:08.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Simple/sample_tests/death.plx 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -4,10 +4,13 @@
|
|
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?";
|
|
+$! = 0;
|
|
+die "This is a test";
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death_with_handler.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/death_with_handler.plx
|
|
--- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death_with_handler.plx 1970-01-01 01:00:00.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Simple/sample_tests/death_with_handler.plx 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -0,0 +1,20 @@
|
|
+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);
|
|
+
|
|
+$! = 0;
|
|
+die "This is a test";
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/last_minute_death.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/last_minute_death.plx
|
|
--- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2007-12-18 11:47:08.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -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,5 @@
|
|
ok(1);
|
|
ok(1);
|
|
|
|
-die "Almost there...";
|
|
+$! = 0;
|
|
+die "This is a test";
|
|
diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/too_few_fail.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/too_few_fail.plx
|
|
--- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/too_few_fail.plx 2007-12-18 11:47:08.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/Test/Simple/sample_tests/too_few_fail.plx 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -9,4 +9,4 @@
|
|
|
|
ok(0);
|
|
ok(1);
|
|
-ok(0);
|
|
\ No newline at end of file
|
|
+ok(0);
|
|
diff -urN perl-5.10.0.orig/t/lib/TieOut.pm perl-5.10.0/t/lib/TieOut.pm
|
|
--- perl-5.10.0.orig/t/lib/TieOut.pm 2007-12-18 11:47:08.000000000 +0100
|
|
+++ perl-5.10.0/t/lib/TieOut.pm 2009-08-26 06:14:11.000000000 +0200
|
|
@@ -1,13 +1,15 @@
|
|
package TieOut;
|
|
|
|
+use strict;
|
|
+
|
|
sub TIEHANDLE {
|
|
my $scalar = '';
|
|
- bless( \$scalar, $_[0]);
|
|
+ bless( \$scalar, $_[0] );
|
|
}
|
|
|
|
sub PRINT {
|
|
my $self = shift;
|
|
- $$self .= join('', @_);
|
|
+ $$self .= join( '', @_ );
|
|
}
|
|
|
|
sub PRINTF {
|
|
@@ -16,7 +18,7 @@
|
|
$$self .= sprintf $fmt, @_;
|
|
}
|
|
|
|
-sub FILENO {}
|
|
+sub FILENO { }
|
|
|
|
sub read {
|
|
my $self = shift;
|