lib/Term/ReadLine.pm Stub readline library
lib/Term/ReadLine.t See if Term::ReadLine works
lib/Test/Builder.pm For writing new test libraries
+lib/Test/Builder/Module.pm Base class for test modules
lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only)
lib/Test/Harness/bin/prove The prove harness utility
lib/Test/Harness/Changes Test::Harness
lib/Test/Simple/README Test::Simple README
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/buffer.t Test::Builder buffering test
lib/Test/Simple/t/Builder.t Test::Builder tests
lib/Test/Simple/t/circular_data.t Test::Simple test
t/lib/Test/Simple/sample_tests/require.plx for exit.t
t/lib/Test/Simple/sample_tests/success.plx for exit.t
t/lib/Test/Simple/sample_tests/too_few.plx for exit.t
+t/lib/Test/Simple/sample_tests/too_few_fail.plx for exit.t
t/lib/Test/Simple/sample_tests/two_fail.plx for exit.t
t/lib/TieIn.pm Testing library for dummy input handles
t/lib/TieOut.pm Testing library to capture prints
use strict;
use vars qw($VERSION);
-$VERSION = '0.30';
+$VERSION = '0.31';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
- $self->_unoverload(\$name);
+ $self->_unoverload_str(\$name);
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
my($pack, $file, $line) = $self->caller;
my $todo = $self->todo($pack);
- $self->_unoverload(\$todo);
+ $self->_unoverload_str(\$todo);
my $out;
my $result = &share({});
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
- $self->diag(" $msg test ($file at line $line)\n");
+
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ in $file at line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test in $file at line $line.\n]);
+ }
}
return $test ? 1 : 0;
sub _unoverload {
my $self = shift;
+ my $type = shift;
local($@,$!);
foreach my $thing (@_) {
eval {
- if( defined $$thing ) {
- if( my $string_meth = overload::Method($$thing, '""') ) {
+ if( _is_object($$thing) ) {
+ if( my $string_meth = overload::Method($$thing, $type) ) {
$$thing = $$thing->$string_meth();
}
}
}
+sub _is_object {
+ my $thing = shift;
+
+ return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
+}
+
+
+sub _unoverload_str {
+ my $self = shift;
+
+ $self->_unoverload(q[""], @_);
+}
+
+sub _unoverload_num {
+ my $self = shift;
+
+ $self->_unoverload('0+', @_);
+
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val+0;
+ }
+}
+
+
+# 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;
+}
+
+
+
=item B<is_eq>
$Test->is_eq($got, $expected, $name);
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
+ $self->_unoverload_str(\$got, \$expect);
+
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
+ $self->_unoverload_num(\$got, \$expect);
+
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
}
else {
# force numeric context
- $$val = $$val+0;
+ $self->_unoverload_num($val);
}
}
else {
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
- local $Level = $Level + 1;
-
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
}
{
- local $^W = 0;
- my $test = $this =~ /$usable_regex/ ? 1 : 0;
+ my $test;
+ my $code = $self->_caller_context;
+
+ local($@, $!);
+
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
+ # Don't ask me, man, I just work here.
+ $test = eval "
+$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
$test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
=cut
+
+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 $test;
{
- local $^W = 0;
local($@,$!); # don't interfere with $@
# eval() sometimes resets $!
- $test = eval "\$got $type \$expect";
+
+ my $code = $self->_caller_context;
+
+ # 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;";
+
}
local $Level = $Level + 1;
my $ok = $self->ok($test, $name);
DIAGNOSTIC
}
-=item B<BAILOUT>
- $Test->BAILOUT($reason);
+sub _caller_context {
+ my $self = shift;
+
+ my($pack, $file, $line) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
Indicates to the Test::Harness that things are going so badly all
testing should terminate. This includes running any additional test
=cut
-sub BAILOUT {
+sub BAIL_OUT {
my($self, $reason) = @_;
+ $self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+*BAILOUT = \&BAIL_OUT;
+
+
=item B<skip>
$Test->skip;
sub skip {
my($self, $why) = @_;
$why ||= '';
- $self->_unoverload(\$why);
+ $self->_unoverload_str(\$why);
unless( $self->{Have_Plan} ) {
require Carp;
return $self->{Use_Nums};
}
-=item B<no_header>
- $Test->no_header($no_header);
+=item B<no_diag>
-If set to true, no "1..N" header will be printed.
+ $Test->no_diag($no_diag);
+
+If set true no diagnostics will be printed. This includes calls to
+diag().
=item B<no_ending>
If this is true, none of that will be done.
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
=cut
-sub no_header {
- my($self, $no_header) = @_;
+foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
+ my $method = lc $attribute;
- if( defined $no_header ) {
- $self->{No_Header} = $no_header;
- }
- return $self->{No_Header};
-}
+ my $code = sub {
+ my($self, $no) = @_;
-sub no_ending {
- my($self, $no_ending) = @_;
+ if( defined $no ) {
+ $self->{$attribute} = $no;
+ }
+ return $self->{$attribute};
+ };
- if( defined $no_ending ) {
- $self->{No_Ending} = $no_ending;
- }
- return $self->{No_Ending};
+ no strict 'refs';
+ *{__PACKAGE__.'::'.$method} = $code;
}
sub diag {
my($self, @msgs) = @_;
+
+ return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
sub _is_fh {
my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
# should do the ending.
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
- if( ($self->{Original_Pid} != $$) or
- (!$self->{Have_Plan} && !$self->{Test_Died}) )
+ # 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;
}
my $num_failed = grep !$_->{'ok'},
- @{$test_results}[0..$self->{Expected_Tests}-1];
- $num_failed += abs($self->{Expected_Tests} - @$test_results);
+ @{$test_results}[0..$self->{Curr_Test}-1];
- if( $self->{Curr_Test} < $self->{Expected_Tests} ) {
+ 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( $self->{Curr_Test} > $self->{Expected_Tests} ) {
- my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+ elsif( $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.
FAIL
}
- elsif ( $num_failed ) {
+
+ if ( $num_failed ) {
+ my $num_tests = $self->{Curr_Test};
my $s = $num_failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
$self->diag(<<"FAIL");
-Looks like you failed $num_failed test$s of $self->{Expected_Tests}.
+Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
}
_my_exit( 255 ) && return;
}
- _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
+ my $exit_code;
+ if( $num_failed ) {
+ $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ }
+ elsif( $num_extra != 0 ) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ _my_exit( $exit_code ) && return;
}
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
So the exit codes are...
0 all tests successful
- 255 test died
+ 255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
--- /dev/null
+package Test::Builder::Module;
+
+use Test::Builder;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = '0.02';
+
+use strict;
+
+# 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, @_);
+};
+
+
+=head1 NAME
+
+Test::Builder::Module - Base class for test modules
+
+=head1 SYNOPSIS
+
+ # Emulates Test::Simple
+ package Your::Module;
+
+ my $CLASS = __PACKAGE__;
+
+ use base 'Test::Builder::Module';
+ @EXPORT = qw(ok);
+
+ sub ok ($;$) {
+ my $tb = $CLASS->builder;
+ return $tb->ok(@_);
+ }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This is a superclass for Test::Builder-based modules. It provides a
+handful of common functionality and a method of getting at the underlying
+Test::Builder object.
+
+
+=head2 Importing
+
+Test::Builder::Module is a subclass of Exporter which means your
+module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
+all act normally.
+
+A few methods are provided to do the C<use Your::Module tests => 23> part
+for you.
+
+=head3 import
+
+Test::Builder::Module provides an import() method which acts in the
+same basic way as Test::More's, setting the plan and controling
+exporting of functions and variables. This allows your module to set
+the plan independent of Test::More.
+
+All arguments passed to import() are passed onto
+C<< Your::Module->builder->plan() >> with the exception of
+C<import =>[qw(things to import)]>.
+
+ use Your::Module import => [qw(this that)], tests => 23;
+
+says to import the functions this() and that() as well as set the plan
+to be 23 tests.
+
+import() also sets the exported_to() attribute of your builder to be
+the caller of the import() function.
+
+Additional behaviors can be added to your import() method by overriding
+import_extra().
+
+=cut
+
+sub import {
+ my($class) = shift;
+
+ my $test = $class->builder;
+
+ my $caller = caller;
+
+ $test->exported_to($caller);
+
+ $class->import_extra(\@_);
+ my(@imports) = $class->_strip_imports(\@_);
+
+ $test->plan(@_);
+
+ $class->$_export_to_level(1, $class, @imports);
+}
+
+
+sub _strip_imports {
+ my $class = shift;
+ my $list = shift;
+
+ my @imports = ();
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'import' ) {
+ push @imports, @{$list->[$idx+1]};
+ $idx++;
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return @imports;
+}
+
+
+=head3 import_extra
+
+ Your::Module->import_extra(\@import_args);
+
+import_extra() is called by import(). It provides an opportunity for you
+to add behaviors to your module based on its import list.
+
+Any extra arguments which shouldn't be passed on to plan() should be
+stripped off by this method.
+
+See Test::More for an example of its use.
+
+B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
+feels like a bit of an ugly hack in its current form.
+
+=cut
+
+sub import_extra {}
+
+
+=head2 Builder
+
+Test::Builder::Module provides some methods of getting at the underlying
+Test::Builder object.
+
+=head3 builder
+
+ my $builder = Your::Class->builder;
+
+This method returns the Test::Builder object associated with Your::Class.
+It is not a constructor so you can call it as often as you like.
+
+This is the preferred way to get the Test::Builder object. You should
+I<not> get it via C<< Test::Builder->new >> as was previously
+recommended.
+
+The object returned by builder() may change at runtime so you should
+call builder() inside each function rather than store it in a global.
+
+ sub ok {
+ my $builder = Your::Class->builder;
+
+ return $builder->ok(@_);
+ }
+
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+
+1;
use 5.004;
use strict;
-use Test::Builder;
# Can't use Carp because it might cause use_ok() to accidentally succeed
-require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.60';
+$VERSION = '0.61';
$VERSION = eval $VERSION; # make the alpha version come out as a number
-@ISA = qw(Exporter);
+use Test::Builder::Module;
+@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
plan
can_ok isa_ok
diag
+ BAIL_OUT
);
-my $Test = Test::Builder->new;
-my $Show_Diag = 1;
-
-
-# 5.004's Exporter doesn't have export_to_level.
-sub _export_to_level
-{
- my $pkg = shift;
- my $level = shift;
- (undef) = shift; # redundant arg
- my $callpkg = caller($level);
- $pkg->export($callpkg, @_);
-}
-
=head1 NAME
pass($test_name);
fail($test_name);
- # UNIMPLEMENTED!!!
- my @status = Test::More::status;
+ BAIL_OUT($why);
# UNIMPLEMENTED!!!
- BAIL_OUT($why);
+ my @status = Test::More::status;
=head1 DESCRIPTION
use Test::More qw(no_plan);
B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
-think everything has failed. See L<BUGS and CAVEATS>)
+think everything has failed. See L<CAVEATS and NOTES>).
In some cases, you'll want to completely skip an entire testing script.
=cut
sub plan {
- my(@plan) = @_;
-
- my $idx = 0;
- my @cleaned_plan;
- while( $idx <= $#plan ) {
- my $item = $plan[$idx];
+ my $tb = Test::More->builder;
- if( $item eq 'no_diag' ) {
- $Show_Diag = 0;
- }
- else {
- push @cleaned_plan, $item;
- }
-
- $idx++;
- }
-
- $Test->plan(@cleaned_plan);
+ $tb->plan(@_);
}
-sub import {
- my($class) = shift;
-
- my $caller = caller;
- $Test->exported_to($caller);
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
+ my @other = ();
my $idx = 0;
- my @plan;
- my @imports;
- while( $idx <= $#_ ) {
- my $item = $_[$idx];
-
- if( $item eq 'import' ) {
- push @imports, @{$_[$idx+1]};
- $idx++;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
}
else {
- push @plan, $item;
+ push @other, $item;
}
$idx++;
}
- plan(@plan);
-
- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+ @$list = @other;
}
Should an ok() fail, it will produce some diagnostics:
not ok 18 - sufficient mucus
- # Failed test 18 (foo.t at line 42)
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
This is actually Test::Simple's ok() routine.
sub ok ($;$) {
my($test, $name) = @_;
- $Test->ok($test, $name);
+ my $tb = Test::More->builder;
+
+ $tb->ok($test, $name);
}
=item B<is>
Will produce something like this:
not ok 17 - Is foo the same as bar?
- # Failed test (foo.t at line 139)
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
# got: 'waffle'
# expected: 'yarblokos'
=cut
sub is ($$;$) {
- $Test->is_eq(@_);
+ my $tb = Test::More->builder;
+
+ $tb->is_eq(@_);
}
sub isnt ($$;$) {
- $Test->isnt_eq(@_);
+ my $tb = Test::More->builder;
+
+ $tb->isnt_eq(@_);
}
*isn't = \&isnt;
=cut
sub like ($$;$) {
- $Test->like(@_);
+ my $tb = Test::More->builder;
+
+ $tb->like(@_);
}
=cut
sub unlike ($$;$) {
- $Test->unlike(@_);
+ my $tb = Test::More->builder;
+
+ $tb->unlike(@_);
}
and $that were:
not ok 1
- # Failed test (foo.t at line 12)
+ # Failed test in foo.t at line 12.
# '23'
# &&
# undef
=cut
sub cmp_ok($$$;$) {
- $Test->cmp_ok(@_);
+ my $tb = Test::More->builder;
+
+ $tb->cmp_ok(@_);
}
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
unless( @methods ) {
- my $ok = $Test->ok( 0, "$class->can(...)" );
- $Test->diag(' can_ok() called with no methods');
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
return $ok;
}
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
- my $ok = $Test->ok( !@nok, $name );
+ my $ok = $tb->ok( !@nok, $name );
- $Test->diag(map " $class->can('$_') failed\n", @nok);
+ $tb->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
+ my $tb = Test::More->builder;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $ok;
if( $diag ) {
- $ok = $Test->ok( 0, $name );
- $Test->diag(" $diag\n");
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
}
else {
- $ok = $Test->ok( 1, $name );
+ $ok = $tb->ok( 1, $name );
}
return $ok;
=cut
sub pass (;$) {
- $Test->ok(1, @_);
+ my $tb = Test::More->builder;
+ $tb->ok(1, @_);
}
sub fail (;$) {
- $Test->ok(0, @_);
+ my $tb = Test::More->builder;
+ $tb->ok(0, @_);
}
=back
-=head2 Diagnostics
-
-If you pick the right test function, you'll usually get a good idea of
-what went wrong when it failed. But sometimes it doesn't work out
-that way. So here we have ways for you to write your own diagnostic
-messages which are safer than just C<print STDERR>.
-
-=over 4
-
-=item B<diag>
-
- diag(@diagnostic_message);
-
-Prints a diagnostic message which is guaranteed not to interfere with
-test output. Like C<print> @diagnostic_message is simply concatenated
-together.
-
-Handy for this sort of thing:
-
- ok( grep(/foo/, @users), "There's a foo user" ) or
- diag("Since there's no foo, check that /etc/bar is set up right");
-
-which would produce:
-
- not ok 42 - There's a foo user
- # Failed test (foo.t at line 52)
- # Since there's no foo, check that /etc/bar is set up right.
-
-You might remember C<ok() or diag()> with the mnemonic C<open() or
-die()>.
-
-All diag()s can be made silent by passing the "no_diag" option to
-Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful
-if you have diagnostics for personal testing but then wish to make
-them silent for release without commenting out each individual
-statement.
-
-B<NOTE> The exact formatting of the diagnostic output is still
-changing, but it is guaranteed that whatever you throw at it it won't
-interfere with the test.
-
-=cut
-
-sub diag {
- return unless $Show_Diag;
- $Test->diag(@_);
-}
-
-
-=back
=head2 Module tests
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
+ my $tb = Test::More->builder;
my($pack,$filename,$line) = caller;
USE
}
- my $ok = $Test->ok( !$@, "use $module;" );
+ my $ok = $tb->ok( !$@, "use $module;" );
unless( $ok ) {
chomp $@;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at $filename line $line.}m;
- $Test->diag(<<DIAGNOSTIC);
+ $tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
Error: $@
DIAGNOSTIC
sub require_ok ($) {
my($module) = shift;
+ my $tb = Test::More->builder;
my $pack = caller;
require $module;
REQUIRE
- my $ok = $Test->ok( !$@, "require $module;" );
+ my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
chomp $@;
- $Test->diag(<<DIAGNOSTIC);
+ $tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $@
DIAGNOSTIC
=back
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $this, $that, $test_name );
+
+Similar to is(), except that if $this and $that are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+Test::Differences and Test::Deep provide more in-depth functionality
+along these lines.
+
+=cut
+
+use vars qw(@Data_Stack %Refs_Seen);
+my $DNE = bless [], 'Does::Not::Exist';
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless( @_ == 2 or @_ == 3 ) {
+ 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
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my($this, $that, $name) = @_;
+
+ $tb->_unoverload_str(\$that, \$this);
+
+ my $ok;
+ if( !ref $this and !ref $that ) { # neither is a reference
+ $ok = $tb->is_eq($this, $that, $name);
+ }
+ elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
+ $ok = $tb->ok(0, $name);
+ $tb->diag( _format_stack({ vals => [ $this, $that ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check($this, $that) ) {
+ $ok = $tb->ok(1, $name);
+ }
+ else {
+ $ok = $tb->ok(0, $name);
+ $tb->diag(_format_stack(@Data_Stack));
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{$Stack[-1]{vals}}[0,1];
+ my @vars = ();
+ ($vars[0] = $var) =~ s/\$FOO/ \$got/;
+ ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx (0..$#vals) {
+ my $val = $vals[$idx];
+ $vals[$idx] = !defined $val ? 'undef' :
+ $val eq $DNE ? "Does not exist" :
+ ref $val ? "$val" :
+ "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) {
+ return $type if UNIVERSAL::isa($thing, $type);
+ }
+
+ return '';
+}
+
+=back
+
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ my $tb = Test::More->builder;
+
+ $tb->diag(@_);
+}
+
+
+=back
+
+
=head2 Conditional tests
Sometimes running a test under certain conditions will cause the
#'#
sub skip {
my($why, $how_many) = @_;
+ my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
- unless $Test->has_plan eq 'no_plan';
+ unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
- $Test->skip($why);
+ $tb->skip($why);
}
local $^W = 0;
When the block is empty, delete it.
B<NOTE>: TODO tests require a Test::Harness upgrade else it will
-treat it as a normal failure. See L<BUGS and CAVEATS>)
+treat it as a normal failure. See L<CAVEATS and NOTES>).
=item B<todo_skip>
sub todo_skip {
my($why, $how_many) = @_;
+ my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $Test->has_plan eq 'no_plan';
+ unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
- $Test->todo_skip($why);
+ $tb->todo_skip($why);
}
local $^W = 0;
=back
-=head2 Complex data structures
-Not everything is a simple eq check or regex. There are times you
-need to see if two data structures are equivalent. For these
-instances Test::More provides a handful of useful functions.
-
-B<NOTE> I'm not quite sure what will happen with filehandles.
+=head2 Test control
=over 4
-=item B<is_deeply>
+=item B<BAIL_OUT>
- is_deeply( $this, $that, $test_name );
+ BAIL_OUT($reason);
-Similar to is(), except that if $this and $that are hash or array
-references, it does a deep comparison walking each data structure to
-see if they are equivalent. If the two structures are different, it
-will display the place where they start differing.
+Incidates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
-Test::Differences and Test::Deep provide more in-depth functionality
-along these lines.
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
-=cut
+The test will exit with 255.
-use vars qw(@Data_Stack %Refs_Seen);
-my $DNE = bless [], 'Does::Not::Exist';
-sub is_deeply {
- unless( @_ == 2 or @_ == 3 ) {
- 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
-
- _carp sprintf $msg, scalar @_;
-
- return $Test->ok(0);
- }
-
- my($this, $that, $name) = @_;
-
- my $ok;
- if( !ref $this and !ref $that ) { # neither is a reference
- $ok = $Test->is_eq($this, $that, $name);
- }
- elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
- $ok = $Test->ok(0, $name);
- $Test->diag( _format_stack({ vals => [ $this, $that ] }) );
- }
- else { # both references
- local @Data_Stack = ();
- if( _deep_check($this, $that) ) {
- $ok = $Test->ok(1, $name);
- }
- else {
- $ok = $Test->ok(0, $name);
- $Test->diag(_format_stack(@Data_Stack));
- }
- }
-
- return $ok;
-}
-
-sub _format_stack {
- my(@Stack) = @_;
-
- my $var = '$FOO';
- my $did_arrow = 0;
- foreach my $entry (@Stack) {
- my $type = $entry->{type} || '';
- my $idx = $entry->{'idx'};
- if( $type eq 'HASH' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "{$idx}";
- }
- elsif( $type eq 'ARRAY' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "[$idx]";
- }
- elsif( $type eq 'REF' ) {
- $var = "\${$var}";
- }
- }
-
- my @vals = @{$Stack[-1]{vals}}[0,1];
- my @vars = ();
- ($vars[0] = $var) =~ s/\$FOO/ \$got/;
- ($vars[1] = $var) =~ s/\$FOO/\$expected/;
-
- my $out = "Structures begin differing at:\n";
- foreach my $idx (0..$#vals) {
- my $val = $vals[$idx];
- $vals[$idx] = !defined $val ? 'undef' :
- $val eq $DNE ? "Does not exist" :
- ref $val ? "$val" :
- "'$val'";
- }
+=cut
- $out .= "$vars[0] = $vals[0]\n";
- $out .= "$vars[1] = $vals[1]\n";
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
- $out =~ s/^/ /msg;
- return $out;
+ $tb->BAIL_OUT($reason);
}
-
-sub _type {
- my $thing = shift;
-
- return '' if !ref $thing;
-
- for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) {
- return $type if UNIVERSAL::isa($thing, $type);
- }
-
- return '';
-}
+=back
=head2 Discouraged comparison functions
They may be deprecated in future versions.
+=over 4
=item B<eq_array>
sub _deep_check {
my($e1, $e2) = @_;
+ my $tb = Test::More->builder;
+
my $ok = 0;
# Effectively turn %Refs_Seen into a stack. This avoids picking up
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
- $Test->_unoverload(\$e1, \$e2);
+ $tb->_unoverload_str(\$e1, \$e2);
# Either they're both references or both not.
my $same_ref = !(!ref $e1 xor !ref $e2);
B<NOTE> By historical accident, this is not a true set comparison.
While the order of elements does not matter, duplicate elements do.
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
Test::Deep contains much better set comparison functions.
=cut
# There's faster ways to do this, but this is easiest.
local $^W = 0;
- # We must make sure that references are treated neutrally. It really
- # doesn't matter how we sort them, as long as both arrays are sorted
- # with the same algorithm.
+ # 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
+ # string containing the reference.
+ #
# Have to inline the sort routine due to a threading/sort bug.
# See [rt.cpan.org 6782]
+ #
+ # 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(
- [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1],
- [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2]
+ [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
+ [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
);
}
Returns the Test::Builder object underlying Test::More for you to play
with.
-=cut
-
-sub builder {
- return Test::Builder->new;
-}
=back
So the exit codes are...
0 all tests successful
- 255 test died
+ 255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
=item Overloaded objects
-String overloaded objects are compared B<as strings>. This prevents
-Test::More from piercing an object's interface allowing better blackbox
-testing. So if a function starts returning overloaded objects instead of
-bare strings your tests won't notice the difference. This is good.
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
However, it does mean that functions like is_deeply() cannot be used to
test the internals of string overloaded objects. In this case I would
use 5.004;
use strict 'vars';
-use vars qw($VERSION);
-$VERSION = '0.60';
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '0.61';
$VERSION = eval $VERSION; # make the alpha version come out as a number
+use Test::Builder::Module;
+@ISA = qw(Test::Builder::Module);
+@EXPORT = qw(ok);
-use Test::Builder;
-my $Test = Test::Builder->new;
-
-sub import {
- my $self = shift;
- my $caller = caller;
- *{$caller.'::ok'} = \&ok;
-
- $Test->exported_to($caller);
- $Test->plan(@_);
-}
+my $CLASS = __PACKAGE__;
=head1 NAME
=cut
sub ok ($;$) {
- $Test->ok(@_);
+ $CLASS->builder->ok(@_);
}
So the exit codes are...
0 all tests successful
- 255 test died
+ 255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
ok 2 - Title() get
ok 3 - Director() get
not ok 4 - Rating() get
- # Failed test (t/film.t at line 14)
+ # Failed test 'Rating() get'
+ # in t/film.t at line 14.
ok 5 - NumExplodingSheep() get
# Looks like you failed 1 tests of 5
+0.61 Fri Sep 23 23:26:05 PDT 2005
+ - create.t was trying to read from a file before it had been closed
+ (and thus the changes may not have yet been written).
+ * is_deeply() would call stringification methods on non-object strings
+ which happened to be the name of a string overloaded class.
+ [rt.cpan.org 14675]
+
+0.60_02 Tue Aug 9 00:27:41 PDT 2005
+ * Added Test::Builder::Module.
+ - Changed Test::More and Test::Simple to use Test::Builder::Module
+ - Minor Win32 testing nit in fail-more.t
+ * Added no_diag() method to Test::Builder and changed Test::More's
+ no_diag internals to use that. [rt.cpan.org 8655]
+ * Deprecated no_diag() as an option to "use Test::More". Call the
+ Test::Builder method instead.
+
+0.60_01 Sun Jul 3 18:11:58 PDT 2005
+ - Moved the docs around a little to better group all the testing
+ functions together. [rt.cpan.org 8388]
+ * Added a BAIL_OUT() function to Test::More [rt.cpan.org 8381]
+ - Changed Test::Builder->BAILOUT to BAIL_OUT to match other method's
+ naming conventions. BAILOUT remains but is deprecated.
+ * Changed the standard failure diagnostics to include the test name.
+ [rt.cpan.org 12490]
+ - is_deeply() was broken for overloaded objects in the top level in
+ 0.59_01. [rt.cpan.org 13506]
+ - String overloaded objects without an 'eq' or '==' method are now
+ handled in cmp_ok() and is().
+ - cmp_ok() will now treat overloaded objects as numbers if the comparison
+ operator is numeric. [rt.cpan.org 13156]
+ - cmp_ok(), like() and unlike will now throw uninit warnings if their
+ arguments are undefined. [rt.cpan.org 13155]
+ - cmp_ok() will now throw warnings as if the comparison were run
+ normally, for example cmp_ok(2, '==', 'foo') will warn about 'foo'
+ not being numeric. Previously all warnings in the comparison were
+ supressed. [rt.cpan.org 13155]
+ - Tests will now report *both* the number of tests failed and if the
+ wrong number of tests were run. Previously if tests failed and the
+ wrong number were run it would only report the latter.
+ [rt.cpan.org 13494]
+ - Missing or extra tests are not considered failures for the purposes
+ of calculating the exit code. Should there be no failures but the
+ wrong number of tests the exit code will be 254.
+ - Avoiding an unbalanced sort in eq_set() [bugs.perl.org 36354]
+ - Documenting that eq_set() doesn't deal well with refs.
+ - Clarified how is_deeply() compares a bit.
+ * Once again working on 5.4.5.
+
0.60 Tue May 3 14:20:34 PDT 2005
0.59_01 Tue Apr 26 21:51:12 PDT 2005
use Test::More;
plan tests => 1;
+my $TH_Version = 2.03;
+
require Test::Harness;
-unless( cmp_ok( $Test::Harness::VERSION, '>', 1.20, "T::H version" ) ) {
+unless( cmp_ok( $Test::Harness::VERSION, '>', $TH_Version, "T::H version" ) ) {
diag <<INSTRUCTIONS;
Test::Simple/More/Builder has features which depend on a version of
-Test::Harness greater than 1.20. You have $Test::Harness::VERSION.
+Test::Harness greater than $TH_Version. You have $Test::Harness::VERSION.
Please install a new version from CPAN.
If you've already tried to upgrade Test::Harness and still get this
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+my $Exit_Code;
+BEGIN {
+ *CORE::GLOBAL::exit = sub { $Exit_Code = shift; };
+}
+
+
+use Test::Builder;
+use Test::More;
+use TieOut;
+
+my $output = tie *FAKEOUT, 'TieOut';
+my $TB = Test::More->builder;
+$TB->output(\*FAKEOUT);
+
+my $Test = Test::Builder->create;
+$Test->level(0);
+
+if( $] >= 5.005 ) {
+ $Test->plan(tests => 2);
+}
+else {
+ $Test->plan(skip_all =>
+ 'CORE::GLOBAL::exit, introduced in 5.005, is needed for testing');
+}
+
+
+plan tests => 4;
+
+BAIL_OUT("ROCKS FALL! EVERYONE DIES!");
+
+
+$Test->is_eq( $output->read, <<'OUT' );
+1..4
+Bail out! ROCKS FALL! EVERYONE DIES!
+OUT
+
+$Test->is_eq( $Exit_Code, 255 );
use Test::Builder;
my $more_tb = Test::More->builder;
-my $new_tb = Test::Builder->create;
-
-isa_ok $new_tb, 'Test::Builder';
isa_ok $more_tb, 'Test::Builder';
-isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object';
-
is $more_tb, Test::More->builder, 'create does not interfere with ->builder';
is $more_tb, Test::Builder->new, ' does not interfere with ->new';
-$new_tb->output("some_file");
-END { 1 while unlink "some_file" }
+{
+ my $new_tb = Test::Builder->create;
+
+ isa_ok $new_tb, 'Test::Builder';
+ isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object';
-$new_tb->plan(tests => 1);
-$new_tb->ok(1);
+ $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");
use strict;
use Test::More;
-plan tests => 2;
+plan tests => 4;
# RT 3747
ok( eq_set([1, 2, [3]], [[3], 1, 2]) );
ok( eq_set([1,2,[3]], [1,[3],2]) );
+
+# bugs.perl.org 36354
+my $ref = \2;
+ok( eq_set( [$ref, "$ref", "$ref", $ref],
+ ["$ref", $ref, $ref, "$ref"]
+ ) );
+
+TODO: {
+ local $TODO = q[eq_set() doesn't really handle references];
+
+ ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) );
+}
+
'one_fail.plx' => [1, 4],
'two_fail.plx' => [2, 4],
'five_fail.plx' => [5, 4],
- 'extras.plx' => [3, 4],
- 'too_few.plx' => [4, 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'],
# 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++;
-}
+# 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 => 2);
package main;
ok(0, 'Sar');
END {
- My::Test::ok($$out eq <<OUT);
+ $TB->is_eq($$out, <<OUT);
1..3
ok 1 - Foo
not ok 2 - Bar
not ok 5 - Sar
OUT
- My::Test::ok($$err eq <<ERR);
-# Failed test ($0 at line 31)
-# Failed test ($0 at line 34)
+ $TB->is_eq($$err, <<ERR);
+# Failed test 'Bar'
+# in $0 at line 31.
+# Failed test 'Sar'
+# in $0 at line 34.
# Looks like you planned 3 tests but ran 2 extra.
+# Looks like you failed 2 tests of 5 run.
ERR
exit 0;
# 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++;
-}
+# 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 => 2);
+
+sub is { $TB->is_eq(@_) }
package main;
ok(1);
END {
- My::Test::ok($$out eq <<OUT);
+ My::Test::is($$out, <<OUT);
1..1
ok 1
ok 2
ok 3
OUT
- My::Test::ok($$err eq <<ERR);
+ My::Test::is($$err, <<ERR);
# Looks like you planned 1 test but ran 2 extra.
ERR
use strict;
-require Test::Simple::Catch;
-my($out, $err) = Test::Simple::Catch::caught();
-local $ENV{HARNESS_ACTIVE} = 0;
-
# 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++;
-}
+# 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 => 2);
+
+
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+local $ENV{HARNESS_ACTIVE} = 0;
package main;
END {
- My::Test::ok($$out eq <<OUT, 'failing output');
+ $TB->is_eq($$out, <<OUT, 'failing output');
1..1
not ok 1 - is foo like that
OUT
my $err_re = <<ERR;
-# Failed test \\(.*\\)
+# Failed test 'is foo like that'
+# in .* at line 1\.
# 'foo'
# doesn't match '\\(\\?-xism:that\\)'
# Looks like you failed 1 test of 1\\.
ERR
- My::Test::ok($$err =~ /^$err_re$/, 'failing errors');
+ $TB->like($$err, qr/^$err_re$/, 'failing errors');
exit(0);
}
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
-print "1..12\n";
-
-my $test_num = 1;
-# Utility testing functions.
-sub ok ($;$) {
- my($test, $name) = @_;
- my $ok = '';
- $ok .= "not " unless $test;
- $ok .= "ok $test_num";
- $ok .= " - $name" if defined $name;
- $ok .= "\n";
- print $ok;
- $test_num++;
-
- return $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 => 17);
+
+sub like ($$;$) {
+ $TB->like(@_);
}
+sub is ($$;$) {
+ $TB->is_eq(@_);
+}
sub main::err_ok ($) {
my($expect) = @_;
my $got = $err->read;
- my $ok = ok( $got eq $expect );
-
- unless( $ok ) {
- print STDERR "$got\n";
- print STDERR "$expect\n";
- }
-
- return $ok;
+ return $TB->is_eq( $got, $expect );
}
package main;
require Test::More;
-my $Total = 29;
+my $Total = 28;
Test::More->import(tests => $Total);
my $tb = Test::More->builder;
$tb->use_numbers(0);
+my $Filename = quotemeta $0;
+
# Preserve the line numbers.
#line 38
ok( 0, 'failing' );
err_ok( <<ERR );
-# Failed test ($0 at line 38)
+# Failed test 'failing'
+# in $0 at line 38.
ERR
#line 40
is( undef, 0, 'undef is 0?');
is( '', 0, 'empty string is 0?' );
err_ok( <<ERR );
-# Failed test ($0 at line 40)
+# Failed test 'foo is bar?'
+# in $0 at line 40.
# got: 'foo'
# expected: 'bar'
-# Failed test ($0 at line 41)
+# Failed test 'undef is empty string?'
+# in $0 at line 41.
# got: undef
# expected: ''
-# Failed test ($0 at line 42)
+# Failed test 'undef is 0?'
+# in $0 at line 42.
# got: undef
# expected: '0'
-# Failed test ($0 at line 43)
+# Failed test 'empty string is 0?'
+# in $0 at line 43.
# got: ''
# expected: '0'
ERR
isn't("foo", "foo",'foo isn\'t foo?' );
isnt(undef, undef, 'undef isnt undef?');
err_ok( <<ERR );
-# Failed test ($0 at line 45)
+# Failed test 'foo isnt foo?'
+# in $0 at line 45.
# 'foo'
# ne
# 'foo'
-# Failed test ($0 at line 46)
+# Failed test 'foo isn\'t foo?'
+# in $0 at line 46.
# 'foo'
# ne
# 'foo'
-# Failed test ($0 at line 47)
+# Failed test 'undef isnt undef?'
+# in $0 at line 47.
# undef
# ne
# undef
like( "foo", '/that/', 'is foo like that' );
unlike( "foo", '/foo/', 'is foo unlike foo' );
err_ok( <<ERR );
-# Failed test ($0 at line 48)
+# Failed test 'is foo like that'
+# in $0 at line 48.
# 'foo'
# doesn't match '/that/'
-# Failed test ($0 at line 49)
+# Failed test 'is foo unlike foo'
+# in $0 at line 49.
# 'foo'
# matches '/foo/'
ERR
# Nick Clark found this was a bug. Fixed in 0.40.
+# line 60
like( "bug", '/(%)/', 'regex with % in it' );
err_ok( <<ERR );
-# Failed test ($0 at line 60)
+# Failed test 'regex with % in it'
+# in $0 at line 60.
# 'bug'
# doesn't match '/(%)/'
ERR
+#line 67
fail('fail()');
err_ok( <<ERR );
-# Failed test ($0 at line 67)
+# Failed test 'fail()'
+# in $0 at line 67.
ERR
#line 52
can_ok('Mooble::Hooble::Yooble', qw(this that));
can_ok('Mooble::Hooble::Yooble', ());
err_ok( <<ERR );
-# Failed test ($0 at line 52)
+# Failed test 'Mooble::Hooble::Yooble->can(...)'
+# in $0 at line 52.
# Mooble::Hooble::Yooble->can('this') failed
# Mooble::Hooble::Yooble->can('that') failed
-# Failed test ($0 at line 53)
+# Failed test 'Mooble::Hooble::Yooble->can(...)'
+# in $0 at line 53.
# can_ok() called with no methods
ERR
isa_ok(undef, "Wibble", "Another Wibble");
isa_ok([], "HASH");
err_ok( <<ERR );
-# Failed test ($0 at line 55)
+# Failed test 'The object isa Wibble'
+# in $0 at line 55.
# The object isn't a 'Wibble' it's a 'Foo'
-# Failed test ($0 at line 56)
+# Failed test 'My Wibble isa Wibble'
+# in $0 at line 56.
# My Wibble isn't a reference
-# Failed test ($0 at line 57)
+# Failed test 'Another Wibble isa Wibble'
+# in $0 at line 57.
# Another Wibble isn't defined
-# Failed test ($0 at line 58)
+# Failed test 'The object isa HASH'
+# in $0 at line 58.
# The object isn't a 'HASH' it's a 'ARRAY'
ERR
cmp_ok( 42.1, '==', 23, , ' ==' );
cmp_ok( 42, '!=', 42 , ' !=' );
cmp_ok( 1, '&&', 0 , ' &&' );
-cmp_ok( 42, '==', "foo", ' == with strings' );
-cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
-cmp_ok( undef, 'eq', 'foo', ' eq with undef' );
err_ok( <<ERR );
-# Failed test ($0 at line 68)
+# Failed test 'cmp_ok eq'
+# in $0 at line 68.
# got: 'foo'
# expected: 'bar'
-# Failed test ($0 at line 69)
+# Failed test ' =='
+# in $0 at line 69.
# got: 42.1
# expected: 23
-# Failed test ($0 at line 70)
+# Failed test ' !='
+# in $0 at line 70.
# '42'
# !=
# '42'
-# Failed test ($0 at line 71)
+# Failed test ' &&'
+# in $0 at line 71.
# '1'
# &&
# '0'
-# Failed test ($0 at line 72)
-# got: 42
-# expected: 0
-# Failed test ($0 at line 73)
+ERR
+
+
+# line 196
+cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
+err_ok( <<ERR );
+# Failed test ' eq with numbers'
+# in $0 at line 196.
# got: '42'
# expected: 'foo'
-# Failed test ($0 at line 74)
-# got: undef
-# expected: 'foo'
ERR
+
+{
+ my $warnings;
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+
+# line 211
+ cmp_ok( 42, '==', "foo", ' == with strings' );
+ err_ok( <<ERR );
+# Failed test ' == with strings'
+# in $0 at line 211.
+# got: 42
+# expected: foo
+ERR
+ My::Test::like $warnings,
+ qq[/^Argument "foo" isn't numeric in .* at $Filename line 211\\\.\n\$/];
+
+}
+
+
# generate a $!, it changes its value by context.
-e "wibblehibble";
my $Errno_Number = $!+0;
cmp_ok( $!, 'eq', '', ' eq with stringified errno' );
cmp_ok( $!, '==', -1, ' eq with numerified errno' );
err_ok( <<ERR );
-# Failed test ($0 at line 80)
+# Failed test ' eq with stringified errno'
+# in $0 at line 80.
# got: '$Errno_String'
# expected: ''
-# Failed test ($0 at line 81)
+# Failed test ' eq with numerified errno'
+# in $0 at line 81.
# got: $Errno_Number
# expected: -1
ERR
#line 84
use_ok('Hooble::mooble::yooble');
+
+my $more_err_re = <<ERR;
+# Failed test 'use Hooble::mooble::yooble;'
+# in $Filename at line 84\\.
+# Tried to use 'Hooble::mooble::yooble'.
+# Error: Can't locate Hooble.* in \\\@INC .*
+# BEGIN failed--compilation aborted at $Filename line 84.
+ERR
+
+My::Test::like($err->read, "/^$more_err_re/");
+
+
+#line 85
require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
+$more_err_re = <<ERR;
+# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;'
+# in $Filename at line 85\\.
+# 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/");
+
#line 88
END {
- My::Test::ok($$out eq <<OUT, 'failing output');
+ $TB->is_eq($$out, <<OUT, 'failing output');
1..$Total
not ok - failing
not ok - foo is bar?
not ok - ==
not ok - !=
not ok - &&
-not ok - == with strings
not ok - eq with numbers
-not ok - eq with undef
+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
- my $filename = quotemeta $0;
- my $more_err_re = <<ERR;
-# Failed test \\($filename at line 84\\)
-# Tried to use 'Hooble::mooble::yooble'.
-# Error: Can't locate Hooble.* in \\\@INC .*
-# BEGIN failed--compilation aborted at $filename line 84.
-# Failed test \\($filename at line 85\\)
-# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
-# Error: Can't locate ALL.* in \\\@INC .*
+err_ok( <<ERR );
# Looks like you failed $Total tests of $Total.
ERR
- unless( My::Test::ok($$err =~ /^$more_err_re$/,
- 'failing errors') ) {
- print $$err;
- print "regex:\n";
- print $more_err_re;
- }
-
exit(0);
}
OUT
My::Test::ok($$err eq <<ERR);
-# Failed test ($0 at line 38)
-# Failed test ($0 at line 39)
+# Failed test 'oh no!'
+# in $0 at line 38.
+# Failed test 'damnit'
+# in $0 at line 39.
# Looks like you failed 2 tests of 5.
ERR
OUT
My::Test::ok($$err eq <<ERR) || print $$err;
-# Failed test ($0 at line 45)
+# Failed test in $0 at line 45.
# Looks like you failed 1 test of 1.
ERR
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
-print "1..4\n";
+# 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 => 4);
-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;
+ return $TB->ok(@_);
}
my($expect) = @_;
my $got = $err->read;
- my $ok = ok( $got eq $expect );
-
- unless( $ok ) {
- print STDERR "got\n$got\n";
- print STDERR "expected\n$expect\n";
- }
-
- return $ok;
+ return $TB->is_eq( $got, $expect );
}
#line 62
fail( "this fails" );
err_ok( <<ERR );
-# Failed test ($0 at line 62)
+# Failed test 'this fails'
+# in $0 at line 62.
ERR
#line 72
is( 1, 0 );
err_ok( <<ERR );
-# Failed test ($0 at line 72)
+# Failed test in $0 at line 72.
# got: '1'
# expected: '0'
ERR
fail( "this fails" );
err_ok( <<ERR );
-# Failed test ($0 at line 71)
+# Failed test 'this fails'
+# in $0 at line 71.
ERR
is( 1, 0 );
err_ok( <<ERR );
-# Failed test ($0 at line 84)
+# Failed test in $0 at line 84.
# got: '1'
# expected: '0'
ERR
}
}
-BEGIN {
- require Test::Harness;
-}
-
-# This feature requires a fairly new version of Test::Harness
-if( $Test::Harness::VERSION < 2.03 ) {
- plan tests => 1;
- diag "Need Test::Harness 2.03 or up. You have $Test::Harness::VERSION.";
- fail 'Need Test::Harness 2.03 or up';
- exit;
-}
-
use strict;
use Test::Builder;
sub like ($$;$) {
my($this, $regex, $name) = @_;
- $regex = qr/$regex/ unless ref $regex;
+ $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s;
my $ok = $TB->like($$this, $regex, $name);
ok !is_deeply('foo', 'bar', 'plain strings');
is( $out, "not ok 1 - plain strings\n", 'plain strings' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 68)
+# Failed test 'plain strings'
+# in $0 at line 68.
# got: 'foo'
# expected: 'bar'
ERR
ok !is_deeply({}, [], 'different types');
is( $out, "not ok 2 - different types\n", 'different types' );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test \\($Filename at line 78\\)
+# Failed test 'different types'
+# in $Filename at line 78.
# Structures begin differing at:
# \\\$got = HASH\\(0x[0-9a-f]+\\)
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
is( $out, "not ok 3 - hashes with different values\n",
'hashes with different values' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 88)
+# Failed test 'hashes with different values'
+# in $0 at line 88.
# Structures begin differing at:
# \$got->{this} = '42'
# \$expected->{this} = '43'
is( $out, "not ok 4 - hashes with different keys\n",
'hashes with different keys' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 99)
+# Failed test 'hashes with different keys'
+# in $0 at line 99.
# Structures begin differing at:
# \$got->{this} = Does not exist
# \$expected->{this} = '42'
is( $out, "not ok 5 - arrays of different length\n",
'arrays of different length' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 110)
+# Failed test 'arrays of different length'
+# in $0 at line 110.
# Structures begin differing at:
# \$got->[9] = Does not exist
# \$expected->[9] = '10'
ok !is_deeply([undef, undef], [undef], 'arrays of undefs' );
is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 121)
+# Failed test 'arrays of undefs'
+# in $0 at line 121.
# Structures begin differing at:
# \$got->[1] = undef
# \$expected->[1] = Does not exist
ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' );
is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 131)
+# Failed test 'hashes of undefs'
+# in $0 at line 131.
# Structures begin differing at:
# \$got->{foo} = undef
# \$expected->{foo} = Does not exist
ok !is_deeply(\42, \23, 'scalar refs');
is( $out, "not ok 8 - scalar refs\n", 'scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 141)
+# Failed test 'scalar refs'
+# in $0 at line 141.
# Structures begin differing at:
# \${ \$got} = '42'
# \${\$expected} = '23'
is( $out, "not ok 9 - mixed scalar and array refs\n",
'mixed scalar and array refs' );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test \\($Filename at line 151\\)
+# Failed test 'mixed scalar and array refs'
+# in $Filename at line 151.
# Structures begin differing at:
# \\\$got = ARRAY\\(0x[0-9a-f]+\\)
# \\\$expected = SCALAR\\(0x[0-9a-f]+\\)
ok !is_deeply($a1, $b1, 'deep scalar refs');
is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 173)
+# Failed test 'deep scalar refs'
+# in $0 at line 173.
# Structures begin differing at:
# \${\${ \$got}} = '42'
# \${\${\$expected}} = '23'
ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' );
is( $out, "not ok 11 - deep structures\n", 'deep structures' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 198)
+# Failed test 'deep structures'
+# in $0 at line 198.
# Structures begin differing at:
# \$got->{that}{foo} = Does not exist
# \$expected->{that}{foo} = '42'
ok !is_deeply(@$test);
like \$warning,
- qr/^is_deeply\(\) takes two or three args, you gave $num_args\.\n/;
+ "/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/";
}
ok !is_deeply( [\'a', 'b'], [\'a', 'c'] );
is( $out, "not ok 20\n", 'scalar refs in an array' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 274)
+# Failed test in $0 at line 274.
# Structures begin differing at:
# \$got->[1] = 'b'
# \$expected->[1] = 'c'
ok !is_deeply( 23, $ref );
is( $out, "not ok 21\n", 'scalar vs ref' );
is( $err, <<ERR, ' right diagnostic');
-# Failed test ($0 at line 286)
+# Failed test in $0 at line 286.
# Structures begin differing at:
# \$got = '23'
# \$expected = $ref
ok !is_deeply( $ref, 23 );
is( $out, "not ok 22\n", 'ref vs scalar' );
is( $err, <<ERR, ' right diagnostic');
-# Failed test ($0 at line 296)
+# Failed test in $0 at line 296.
# Structures begin differing at:
# \$got = $ref
# \$expected = '23'
ok !is_deeply( undef, [] );
is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' );
like( $err, <<ERR, ' right diagnostic' );
-# Failed test \\($Filename at line 306\\)
+# Failed test in $Filename at line 306\\.
# Structures begin differing at:
# \\\$got = undef
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
ok !is_deeply( $array, $hash );
is( $out, "not ok 24\n", 'is_deeply and different reference types' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 321)
+# Failed test in $0 at line 321.
# Structures begin differing at:
# \$got = $array
# \$expected = $hash
ok !is_deeply( [$array], [$hash] );
is( $out, "not ok 25\n", 'nested different ref types' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 332)
+# Failed test in $0 at line 332.
# Structures begin differing at:
# \$got->[0] = $array
# \$expected->[0] = $hash
{
package Bar;
- overload->import(q[""] => sub { "wibble" });
+ "overload"->import(q[""] => sub { "wibble" });
}
#line 353
ok !is_deeply( [$foo], [$bar] );
is( $out, "not ok 26\n", 'string overloaded refs respected in diag' );
is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 353)
+# Failed test in $0 at line 353.
# Structures begin differing at:
# \$got->[0] = $foo
# \$expected->[0] = 'wibble'
# 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++;
-}
+# 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 => 2);
+
+sub is { $TB->is_eq(@_) }
package main;
ok(0, 'Bar');
END {
- My::Test::ok($$out eq <<OUT);
+ My::Test::is($$out, <<OUT);
1..5
ok 1 - Foo
not ok 2 - Bar
OUT
- My::Test::ok($$err eq <<ERR);
-# Failed test ($0 at line 31)
+ My::Test::is($$err, <<ERR);
+# Failed test 'Bar'
+# in $0 at line 31.
# Looks like you planned 5 tests but only ran 2.
+# Looks like you failed 1 test of 2 run.
ERR
exit 0;
#!/usr/bin/perl -w
-use Test::More 'no_diag', tests => 1;
+use Test::More 'no_diag', tests => 2;
pass('foo');
diag('This should not be displayed');
+
+is(Test::More->builder->no_diag, 1);
plan skip_all => "needs overload.pm";
}
else {
- plan tests => 7;
+ plan tests => 13;
}
}
use overload
q{""} => sub { $_[0]->{string} },
- q{0} => sub { $_[0]->{num} },
- fallback => 1;
+ q{0+} => sub { $_[0]->{num} };
sub new {
my $class = shift;
is $obj, 'foo', 'is() with string overloading';
cmp_ok $obj, 'eq', 'foo', 'cmp_ok() ...';
-cmp_ok $obj, '==', 'foo', 'cmp_ok() with number overloading';
+cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading';
is_deeply [$obj], ['foo'], 'is_deeply with string overloading';
ok eq_array([$obj], ['foo']), 'eq_array ...';
ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...';
+
+# rt.cpan.org 13506
+is_deeply $obj, 'foo', 'is_deeply with string overloading at the top';
+
+Test::More->builder->is_num($obj, 42);
+Test::More->builder->is_eq ($obj, "foo");
+
+
+{
+ # rt.cpan.org 14675
+ package TestPackage;
+ use overload q{""} => sub { ::fail("This should not be called") };
+
+ package Foo;
+ ::is_deeply(['TestPackage'], ['TestPackage']);
+ ::is_deeply({'TestPackage' => 'TestPackage'},
+ {'TestPackage' => 'TestPackage'});
+ ::is_deeply('TestPackage', 'TestPackage');
+}
}
}
-BEGIN {
- require Test::Harness;
-}
-
-# This feature requires a fairly new version of Test::Harness
-if( $Test::Harness::VERSION < 2.03 ) {
- plan tests => 1;
- diag "Need Test::Harness 2.03 or up. You have $Test::Harness::VERSION.";
- fail 'Need Test::Harness 2.03 or up';
- exit;
-}
-
plan 'no_plan';
pass('Just testing');
}
}
-require Test::Harness;
use Test::More;
-# Shut up a "used only once" warning in 5.5.4.
-my $th_version = $Test::Harness::VERSION = $Test::Harness::VERSION;
-$th_version =~ s/_//; # for X.Y_Z alpha versions
-
-# TODO requires a fairly new version of Test::Harness
-if( $th_version < 2.03 ) {
- plan tests => 1;
- fail "Need Test::Harness 2.03 or up. You have $th_version.";
- exit;
-}
-
plan tests => 18;
}
use strict;
-use Test::More tests => 16;
+use Test::More tests => 18;
use TieOut;
BEGIN { $^W = 1; }
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+my $TB = Test::Builder->new;
+sub no_warnings {
+ $TB->is_eq($warnings, '', ' no warnings');
+ $warnings = '';
+}
+
+sub warnings_is {
+ $TB->is_eq($warnings, $_[0]);
+ $warnings = '';
+}
+
+sub warnings_like {
+ $TB->like($warnings, "/$_[0]/");
+ $warnings = '';
+}
+
+
+my $Filename = quotemeta $0;
+
+
is( undef, undef, 'undef is undef');
-is( $warnings, '', ' no warnings' );
+no_warnings;
isnt( undef, 'foo', 'undef isnt foo');
-is( $warnings, '', ' no warnings' );
+no_warnings;
isnt( undef, '', 'undef isnt an empty string' );
isnt( undef, 0, 'undef isnt zero' );
+#line 45
like( undef, '/.*/', 'undef is like anything' );
-is( $warnings, '', ' no warnings' );
+warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n");
eq_array( [undef, undef], [undef, 23] );
-is( $warnings, '', 'eq_array() no warnings' );
+no_warnings;
eq_hash ( { foo => undef, bar => undef },
{ foo => undef, bar => 23 } );
-is( $warnings, '', 'eq_hash() no warnings' );
+no_warnings;
eq_set ( [undef, undef, 12], [29, undef, undef] );
-is( $warnings, '', 'eq_set() no warnings' );
+no_warnings;
eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } },
{ foo => undef, bar => { baz => undef, moo => 23 } } );
-is( $warnings, '', 'eq_hash() no warnings' );
+no_warnings;
+
+
+#line 64
+cmp_ok( undef, '<=', 2, ' undef <= 2' );
+warnings_like("Use of uninitialized value.* at $Filename line 64\\.\n");
+
my $tb = Test::More->builder;
$tb->failure_output($old_fail);
is( $caught->read, "# undef\n" );
-is( $warnings, '', 'diag(undef) no warnings' );
+no_warnings;
$tb->maybe_regex(undef);
is( $caught->read, '' );
-is( $warnings, '', 'maybe_regex(undef) no warnings' );
+no_warnings;
--- /dev/null
+require Test::Simple;
+
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+
+Test::Simple->import(tests => 5);
+
+
+ok(0);
+ok(1);
+ok(0);
\ No newline at end of file
https://perl5.git.perl.org / perl5.git / commitdiff