lib/Test/Simple/t/has_plan.t Test::Builder->plan tests
lib/Test/Simple/t/import.t Test::More test, importing functions
lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply()
+lib/Test/Simple/t/is_fh.t Test::Builder test, _is_fh()
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
use strict;
use vars qw($VERSION);
-$VERSION = '0.21';
+$VERSION = '0.22';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
use vars qw($Level);
my $Original_Pid;
my @Test_Results; share(@Test_Results);
-my @Test_Details; share(@Test_Details);
my $Exported_To;
my $Expected_Tests;
$Level = 1;
$Original_Pid = $$;
@Test_Results = ();
- @Test_Details = ();
$Exported_To = undef;
$Expected_Tests = 0;
sub maybe_regex {
- my ($self, $regex) = @_;
+ my ($self, $regex) = @_;
my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my($re, $opts);
+
+ # Check for qr/foo/
if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
- # Check if it looks like '/foo/'
- elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
+ # Check for '/foo/' or 'm,foo,'
+ elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
$usable_regex = length $opts ? "(?$opts)$re" : $re;
- };
- return($usable_regex)
+ }
+
+ return $usable_regex;
};
sub _regex_ok {
my $out = "ok";
$out .= " $Curr_Test" if $self->use_numbers;
- $out .= " # skip $why\n";
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
$Test->_print($out);
return $Todo_FH;
}
+
sub _new_fh {
my($file_or_fh) = shift;
my $fh;
- unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
+ if( _is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ else {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
die "Can't open test output log $file_or_fh: $!";
}
- else {
- $fh = $file_or_fh;
- }
return $fh;
}
+
+sub _is_fh {
+ my $maybe_fh = shift;
+
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
+ UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
+
+ # 5.5.4's tied() and can() doesn't like getting undef
+ UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
+}
+
+
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
my $curr_test = $Test->current_test;
$Test->current_test($num);
-Gets/sets the current test # we're on.
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
-You usually shouldn't have to set this.
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
=cut
}
$Curr_Test = $num;
+
+ # If the test counter is being pushed forward fill in the details.
if( $num > @Test_Results ) {
my $start = @Test_Results ? $#Test_Results + 1 : 0;
for ($start..$num-1) {
});
}
}
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @Test_Results ) {
+ $#Test_Results = $num - 1;
+ }
}
return $Curr_Test;
}
require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.53';
+$VERSION = '0.54';
$VERSION = eval $VERSION; # make the alpha version come out as a number
@ISA = qw(Exporter);
If the user does not have HTML::Lint installed, the whole block of
code I<won't be run at all>. Test::More will output special ok's
which Test::Harness interprets as skipped, but passing, tests.
+
It's important that $how_many accurately reflects the number of tests
in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
It's perfectly safe to nest SKIP blocks. Each SKIP block must have
the label C<SKIP>, or Test::More can't work its magic.
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::Builder::No_Plan;
+ unless $Test->has_plan eq 'no_plan';
$how_many = 1;
}
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::Builder::No_Plan;
+ unless $Test->has_plan eq 'no_plan';
$how_many = 1;
}
}
+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 '';
+}
+
+
=item B<eq_array>
eq_array(\@this, \@that);
sub _eq_array {
my($a1, $a2) = @_;
- if( grep !UNIVERSAL::isa($_, 'ARRAY'), $a1, $a2 ) {
+ if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
warn "eq_array passed a non-array ref";
return 0;
}
$ok = 1;
}
else {
- if( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
+ my $type = _type($e1);
+ $type = '' unless _type($e2) eq $type;
+
+ if( !$type ) {
+ push @Data_Stack, { vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
$ok = _eq_array($e1, $e2);
}
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
+ elsif( $type eq 'HASH' ) {
$ok = _eq_hash($e1, $e2);
}
- elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
- {
+ elsif( $type eq 'REF' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
- elsif( UNIVERSAL::isa($e1, 'SCALAR') and
- UNIVERSAL::isa($e2, 'SCALAR') )
- {
+ elsif( $type eq 'SCALAR' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
- else {
- push @Data_Stack, { vals => [$e1, $e2] };
- $ok = 0;
- }
}
}
sub _eq_hash {
my($a1, $a2) = @_;
- if( grep !UNIVERSAL::isa($_, 'HASH'), $a1, $a2 ) {
+ if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
warn "eq_hash passed a non-hash ref";
return 0;
}
use strict 'vars';
use vars qw($VERSION);
-$VERSION = '0.53';
+$VERSION = '0.54';
$VERSION = eval $VERSION; # make the alpha version come out as a number
+0.54 Wed Dec 15 04:18:43 EST 2004
+ * $how_many is optional for skip() and todo_skip(). Thanks to
+ Devel::Cover for pointing this out.
+ - Removed a user defined function called err() in the tests to placate
+ users of older versions of the dor patch before err() was weakend.
+ [rt.cpan.org 8734]
+
+0.53_01 Sat Dec 11 19:02:18 EST 2004
+ - current_test() can now be set backward.
+ - *output() methods now handle tied handles and *FOO{IO} properly.
+ - maybe_regex() now handles undef gracefully.
+ - maybe_regex() now handles 'm,foo,' style regexes.
+ - sort_bug.t wasn't checking for threads properly. Would fail on
+ 5.6 that had ithreads compiled in. [rt.cpan.org 8765]
+
0.53 Mon Nov 29 04:43:24 EST 2004
- Apparently its possible to have Module::Signature installed without
it being functional. Fixed the signature test to account for this.
use Test::Builder;
my $Test = Test::Builder->new;
-$Test->plan( tests => 8 );
+$Test->plan( tests => 9 );
$Test->level(0);
my @Expected_Details;
# 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 $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);
SKIP: {
$Test->skip( 'just testing skip' );
for ($start_test..$Test->current_test) { print "ok $_\n" }
$Test->output($out_fh);
+$Test->todo_output($todo_fh);
$Test->is_num( scalar $Test->summary(), 4, 'summary' );
push @Expected_Details, { 'ok' => 1,
$Test->level(1);
is_deeply( \@details, \@Expected_Details );
+
+
+# This test has to come last because it thrashes the test details.
+{
+ my $curr_test = $Test->current_test;
+ $Test->current_test(4);
+ my @details = $Test->details();
+
+ $Test->current_test($curr_test);
+ $Test->is_num( scalar @details, 4 );
+}
}
-sub main::err ($) {
+sub main::err_ok ($) {
my($expect) = @_;
my $got = $err->read;
# Preserve the line numbers.
#line 38
ok( 0, 'failing' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 38)
ERR
is( undef, '', 'undef is empty string?');
is( undef, 0, 'undef is 0?');
is( '', 0, 'empty string is 0?' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 40)
# got: 'foo'
# expected: 'bar'
isnt("foo", "foo", 'foo isnt foo?' );
isn't("foo", "foo",'foo isn\'t foo?' );
isnt(undef, undef, 'undef isnt undef?');
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 45)
# 'foo'
# ne
#line 48
like( "foo", '/that/', 'is foo like that' );
unlike( "foo", '/foo/', 'is foo unlike foo' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 48)
# 'foo'
# doesn't match '/that/'
# Nick Clark found this was a bug. Fixed in 0.40.
like( "bug", '/(%)/', 'regex with % in it' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 60)
# 'bug'
# doesn't match '/(%)/'
ERR
fail('fail()');
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 67)
ERR
#line 52
can_ok('Mooble::Hooble::Yooble', qw(this that));
can_ok('Mooble::Hooble::Yooble', ());
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 52)
# Mooble::Hooble::Yooble->can('this') failed
# Mooble::Hooble::Yooble->can('that') failed
isa_ok(42, "Wibble", "My Wibble");
isa_ok(undef, "Wibble", "Another Wibble");
isa_ok([], "HASH");
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 55)
# The object isn't a 'Wibble' it's a 'Foo'
# Failed test ($0 at line 56)
cmp_ok( 42, '==', "foo", ' == with strings' );
cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
cmp_ok( undef, 'eq', 'foo', ' eq with undef' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 68)
# got: 'foo'
# expected: 'bar'
#line 80
cmp_ok( $!, 'eq', '', ' eq with stringified errno' );
cmp_ok( $!, '==', -1, ' eq with numerified errno' );
-err( <<ERR );
+err_ok( <<ERR );
# Failed test ($0 at line 80)
# got: '$Errno_String'
# expected: ''
unless( My::Test::ok($$err =~ /^$more_err_re$/,
'failing errors') ) {
print $$err;
+ print "regex:\n";
+ print $more_err_re;
}
exit(0);
}
-sub main::err ($) {
+sub main::err_ok ($) {
my($expect) = @_;
my $got = $err->read;
#line 62
fail( "this fails" );
- err( <<ERR );
+ err_ok( <<ERR );
# Failed test ($0 at line 62)
ERR
#line 72
is( 1, 0 );
- err( <<ERR );
+ err_ok( <<ERR );
# Failed test ($0 at line 72)
# got: '1'
# expected: '0'
#line 71
fail( "this fails" );
- err( <<ERR );
+ err_ok( <<ERR );
# Failed test ($0 at line 71)
ERR
#line 84
is( 1, 0 );
- err( <<ERR );
+ err_ok( <<ERR );
# Failed test ($0 at line 84)
# got: '1'
# Can't use Test.pm, that's a 5.005 thing.
package main;
-print "1..34\n";
+print "1..38\n";
my $test_num = 1;
# Utility testing functions.
# \$got->[1] = 'b'
# \$expected->[1] = 'c'
ERR
+
+
+#line 285
+my $ref = \23;
+is_deeply( 23, $ref );
+is( $out, "not ok 21\n", 'scalar vs ref' );
+is( $err, <<ERR, ' right diagnostic');
+# Failed test ($0 at line 286)
+# Structures begin differing at:
+# \$got = '23'
+# \$expected = '$ref'
+ERR
+
+#line 296
+is_deeply( $ref, 23 );
+is( $out, "not ok 22\n", 'ref vs scalar' );
+is( $err, <<ERR, ' right diagnostic');
+# Failed test ($0 at line 296)
+# Structures begin differing at:
+# \$got = '$ref'
+# \$expected = '23'
+ERR
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More tests => 6;
+use TieOut;
+
+ok( !Test::Builder::_is_fh("foo"), 'string is not a filehandle' );
+
+ok( open(FILE, '>foo') );
+END { unlink 'foo' }
+
+ok( Test::Builder::_is_fh(*FILE) );
+ok( Test::Builder::_is_fh(\*FILE) );
+ok( Test::Builder::_is_fh(*FILE{IO}) );
+
+tie *OUT, 'TieOut';
+ok( Test::Builder::_is_fh(*OUT) );
\ No newline at end of file
}
use strict;
-use Test::More tests => 10;
+use Test::More tests => 13;
use Test::Builder;
my $Test = Test::Builder->new;
ok(('f00' =~ m/$r/), '"//" good match');
ok(('b4r' !~ m/$r/), '"//" bad match');
};
+
+
+{
+ my $r = $Test->maybe_regex('m,foo,i');
+ ok(defined $r, 'm,, detected');
+ ok(('fOO' =~ m/$r/), '"//" good match');
+ ok(('bar' !~ m/$r/), '"//" bad match');
+};
pass('Just testing');
ok(1, 'Testing again');
+
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = join "", @_ };
+ SKIP: {
+ skip 'Just testing skip with no_plan';
+ fail("So very failed");
+ }
+ is( $warning, '', 'skip with no "how_many" ok with no_plan' );
+
+
+ $warning = '';
+ TODO: {
+ todo_skip "Just testing todo_skip";
+
+ fail("Just testing todo");
+ die "todo_skip should prevent this";
+ pass("Again");
+ }
+ is( $warning, '', 'skip with no "how_many" ok with no_plan' );
+}
use Config;
BEGIN {
- require threads if $Config{useithreads};
+ unless ( $] >= 5.008 && $Config{'useithreads'} &&
+ eval { require threads; 'threads'->import; 1; })
+ {
+ print "1..0 # Skip: no threads\n";
+ exit 0;
+ }
}
use Test::More;
# Passes with $nthreads = 1 and with eq_set().
# Passes with $nthreads = 2 and with eq_array().
# Fails with $nthreads = 2 and with eq_set().
-my $nthreads = 2;
+my $Num_Threads = 2;
-if( $Config{useithreads} ) {
- plan tests => $nthreads;
-}
-else {
- plan skip_all => 'no threads';
-}
+plan tests => $Num_Threads;
sub do_one_thread {
}
my @kids = ();
-for my $i (1..$nthreads) {
+for my $i (1..$Num_Threads) {
my $t = threads->new(\&do_one_thread, $i);
print "# parent $$: continue\n";
push(@kids, $t);
require Test::Harness;
use Test::More;
-# This feature requires a fairly new version of Test::Harness
-(my $th_version = $Test::Harness::VERSION) =~ s/_//; # for X.Y_Z alpha versions
+# 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 => 16;
+plan tests => 18;
$Why = 'Just testing the todo interface.';
die "todo_skip should prevent this";
pass("Again");
}
+
+
+{
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = join "", @_ };
+ TODO: {
+ # perl gets the line number a little wrong on the first
+ # statement inside a block.
+ 1 == 1;
+#line 82
+ 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",
+ 'todo_skip without $how_many warning' );
+}
}
use strict;
-use Test::More tests => 14;
+use Test::More tests => 16;
use TieOut;
BEGIN { $^W = 1; }
is( $caught->read, "# undef\n" );
is( $warnings, '', 'diag(undef) no warnings' );
+
+
+$tb->maybe_regex(undef);
+is( $caught->read, '' );
+is( $warnings, '', 'maybe_regex(undef) no warnings' );
projects / p5sagit/p5-mst-13.2.git / commitdiff