In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/66cad4abfc5d793c52a82bd17877e19bb8276665?hp=ad41de7f1edc024bbebd9862b2b56b6486f7189c>
- Log ----------------------------------------------------------------- commit 66cad4abfc5d793c52a82bd17877e19bb8276665 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 20:24:56 2009 +0200 Add a test for the bootstrap rules for tests in t/ M MANIFEST A t/porting/test_bootstrap.t commit 76c3cfbe78336e0cb070b0aac1ead2413441af81 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 19:18:52 2009 +0200 Don't use require in comp/fold.t, as require isn't tested yet. Emit TAP directly. M t/comp/fold.t commit a6d95d3b2a78200d46f5f1182e3d35b2fcc34eae Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 19:16:35 2009 +0200 Give names to all tests in t/comp/fold.t M t/comp/fold.t commit bc8f2ddd12bfb4ed7885096cdab471dc8d1188aa Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 18:57:12 2009 +0200 Move the require './test.pl' to the end of t/comp/hints.t Ideally tests in t/comp wouldn't use require, as require isn't tested yet, but this test really needs runperl(), and really wants to live in t/comp/hints.t, so place it at the end, so that any catestrophic failure only fails the last test. We don't use any other functionality of t/test.pl This test uses hard-coded test numbers, but I'm not convinced that it would be correct to re-write it to use an automatically incrementing counter, as that wouldn't fail in an obvious fashion if some compile-time blocks ran out of order. What we have *will* fail in an informative fashion if compile time blocks do not run correctly. M t/comp/hints.t commit 8b3931378ff96ff45729c95c3ef32a837469a850 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 18:35:59 2009 +0200 Don't use require in comp/multiline.t, as require isn't tested yet. Emit TAP directly. M t/comp/multiline.t commit 6b077bebea000af2a5477d50d7604bab33ee75c2 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 16:07:22 2009 +0200 Don't use require in comp/opsubs.t, as require isn't tested yet. Emit TAP directly. M t/comp/opsubs.t commit d96222f273529fc287bfeb19af28d5217f3f74aa Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 14:17:29 2009 +0200 Don't use require in comp/our.t, as require isn't tested yet. Emit TAP directly. M t/comp/our.t commit c9786f600ff793ec8526cb8722afafeff5cf741e Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 14:13:55 2009 +0200 Don't use require in comp/parser.t, as require isn't tested yet. Emit TAP directly. M t/comp/parser.t commit 1909e25bea0b772d68da5ef64e05c3f088e2f4b4 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 14:06:07 2009 +0200 Don't use require in comp/retainedlines.t, as require isn't tested yet. Emit TAP directly. M t/comp/retainedlines.t commit 12f74f454da64ab4b20589bcacd2432f37418c00 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 13:54:30 2009 +0200 Avoid relying on prototypes working for tests to pass. They aren't tested yet. M t/comp/retainedlines.t commit cf1e28d2637f0459847074ab67bb30cc13d0473a Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 13:48:43 2009 +0200 Don't use require in comp/uproto.t, as require isn't tested yet. Emit TAP directly. M t/comp/uproto.t commit 3d899d640007cb6cbc676620da4d0aba415fdff6 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 13:44:10 2009 +0200 In opt(), use is(..., undef) rather than ok(!defined ...) M t/comp/uproto.t commit 91937335c7980d01674367559f12bd1ab53b6d56 Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 12:54:29 2009 +0200 Move the test for require 5.11.0 not loading strictures to require.t from use.t M t/comp/require.t M t/comp/use.t commit 61ad1ccdd1fb87e147781b339b1726060969106c Author: Nicholas Clark <[email protected]> Date: Fri Oct 9 12:49:05 2009 +0200 Don't use require in comp/utf.t, as require isn't tested yet. So emit TAP directly, rather than utilising test.pl. Like test.pl, avoid using ++, as it has complexity, and that complexity isn't tested yet. M t/comp/utf.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + t/comp/fold.t | 58 ++++++++++++++++++++++++++++++++------- t/comp/hints.t | 64 ++++++++++++++++++++++---------------------- t/comp/multiline.t | 49 +++++++++++++++++++++++++++++---- t/comp/opsubs.t | 63 +++++++++++++++++++++++++++++++++++++++++- t/comp/our.t | 27 ++++++++++++++---- t/comp/parser.t | 63 ++++++++++++++++++++++++++++++++++++------- t/comp/require.t | 8 +++++- t/comp/retainedlines.t | 53 ++++++++++++++++++++++++++++------- t/comp/uproto.t | 56 ++++++++++++++++++++++++++++++++++---- t/comp/use.t | 5 +--- t/comp/utf.t | 16 +++++++--- t/porting/test_bootstrap.t | 47 ++++++++++++++++++++++++++++++++ 13 files changed, 416 insertions(+), 94 deletions(-) create mode 100644 t/porting/test_bootstrap.t diff --git a/MANIFEST b/MANIFEST index 5f7efa3..a59fbc7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4440,6 +4440,7 @@ t/porting/diag.t Test completeness of perldiag.pod t/porting/maintainers.t Test that Porting/Maintaners.pl is up to date t/porting/manifest.t Test that this MANIFEST file is well formed t/porting/podcheck.t Test the POD of shipped modules is well formed +t/porting/test_bootstrap.t Test that the instructions for test bootstrapping aren't accidentally overlooked. t/README Instructions for regression tests t/re/pat_advanced.t See if advanced esoteric patterns work t/re/pat_advanced_thr.t See if advanced esoteric patterns work in another thread diff --git a/t/comp/fold.t b/t/comp/fold.t index 6b18212..23e8e89 100644 --- a/t/comp/fold.t +++ b/t/comp/fold.t @@ -1,12 +1,11 @@ #!./perl -w -require './test.pl'; - # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; -plan (13); +print "1..13\n"; +my $test = 0; # Historically constant folding was performed by evaluating the ops, and if # they threw an exception compilation failed. This was seen as buggy, because @@ -16,24 +15,61 @@ plan (13); # optimisation rather than a behaviour change. +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; +} + +sub like { + my ($got, $pattern, $name) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test - $name\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern, $name); +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'", $name); +} + my $a; $a = eval '$b = 0/0 if 0; 3'; -is ($a, 3); -is ($@, ""); +is ($a, 3, 'constants in conditionals don\'t affect constant folding'); +is ($@, '', 'no error'); my $b = 0; $a = eval 'if ($b) {return sqrt -3} 3'; -is ($a, 3); -is ($@, ""); +is ($a, 3, 'variables in conditionals don\'t affect constant folding'); +is ($@, '', 'no error'); $a = eval q{ $b = eval q{if ($b) {return log 0} 4}; - is ($b, 4); - is ($@, ""); + is ($b, 4, 'inner eval folds constant'); + is ($@, '', 'no error'); 5; }; -is ($a, 5); -is ($@, ""); +is ($a, 5, 'outer eval folds constant'); +is ($@, '', 'no error'); # warn and die hooks should be disabled during constant folding diff --git a/t/comp/hints.t b/t/comp/hints.t index b19fc5f..f197c6b 100644 --- a/t/comp/hints.t +++ b/t/comp/hints.t @@ -2,11 +2,7 @@ # Tests the scoping of $^H and %^H -BEGIN { - chdir 't' if -d 't'; - @INC = qw(. ../lib); -} - +...@inc = '../lib'; BEGIN { print "1..32\n"; } BEGIN { @@ -82,20 +78,9 @@ BEGIN { } } -require 'test.pl'; - -# bug #27040: hints hash was being double-freed -my $result = runperl( - prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', - stderr => 1 -); -print "not " if length $result; -print "ok 15 - double-freeing hints hash\n"; -print "# got: $result\n" if length $result; - { BEGIN{$^H{x}=1}; - for my $tno (16..17) { + for my $tno (15..16) { eval q( print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; $^H{y} = 1; @@ -109,19 +94,19 @@ print "# got: $result\n" if length $result; { $[ = 11; - print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n"; + print +($[ == 11 ? "" : "not "), "ok 17 - setting \$[ affects \$[\n"; our $t11; BEGIN { $t11 = $^H{'$['} } - print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n"; + print +($t11 == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$^H{'\$['}\n"; BEGIN { $^H{'$['} = 22 } - print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n"; + print +($[ == 22 ? "" : "not "), "ok 19 - setting \$^H{'\$['} affects \$[\n"; our $t22; BEGIN { $t22 = $^H{'$['} } - print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n"; + print +($t22 == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$^H{'\$['}\n"; BEGIN { %^H = () } - print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n"; + print +($[ == 0 ? "" : "not "), "ok 21 - clearing \%^H affects \$[\n"; our $t0; BEGIN { $t0 = $^H{'$['} } - print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n"; + print +($t0 == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$^H{'\$['}\n"; } { @@ -129,18 +114,33 @@ print "# got: $result\n" if length $result; BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } - print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n"; - print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n"; - print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n"; + print +($[ == 13 ? "" : "not "), "ok 23 - \$[ correct before require\n"; + print +($ri0 & 0x04000000 ? "" : "not "), "ok 24 - \$^H correct before require\n"; + print +($rf0 eq "z" ? "" : "not "), "ok 25 - \$^H{foo} correct before require\n"; our($ra1, $ri1, $rf1, $rfe1); BEGIN { require "comp/hints.aux"; } - print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n"; - print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n"; - print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n"; + print +($ra1 == 0 ? "" : "not "), "ok 26 - \$[ cleared for require\n"; + print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 27 - \$^H cleared for require\n"; + print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 28 - \$^H{foo} cleared for require\n"; our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } - print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n"; - print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n"; - print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n"; + print +($[ == 13 ? "" : "not "), "ok 29 - \$[ correct after require\n"; + print +($ri2 & 0x04000000 ? "" : "not "), "ok 30 - \$^H correct after require\n"; + print +($rf2 eq "z" ? "" : "not "), "ok 31 - \$^H{foo} correct after require\n"; } + +# Add new tests above this require, in case it fails. +require './test.pl'; + +# bug #27040: hints hash was being double-freed +my $result = runperl( + prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', + stderr => 1 +); +print "not " if length $result; +print "ok 32 - double-freeing hints hash\n"; +print "# got: $result\n" if length $result; + +__END__ +# Add new tests above require 'test.pl' diff --git a/t/comp/multiline.t b/t/comp/multiline.t index 6976590..fc49484 100644 --- a/t/comp/multiline.t +++ b/t/comp/multiline.t @@ -1,14 +1,51 @@ #!./perl -BEGIN { - chdir 't'; - @INC = '../lib'; - require './test.pl'; +print "1..6\n"; +my $test = 0; + +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; } -plan(tests => 6); +sub like { + my ($got, $pattern, $name) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test - $name\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern); +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'"); +} + +my $filename = "multiline$$"; + +END { + 1 while unlink $filename; +} -my $filename = tempfile(); open(TRY,'>',$filename) || (die "Can't open $filename: $!"); $x = 'now is the time diff --git a/t/comp/opsubs.t b/t/comp/opsubs.t index 69d8049..05610c9 100644 --- a/t/comp/opsubs.t +++ b/t/comp/opsubs.t @@ -6,9 +6,68 @@ $|++; -require "./test.pl"; +print "1..36\n"; +my $test = 0; + +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; +} -plan(tests => 36); +sub like { + my ($got, $pattern, $name) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test - $name\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern); +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'"); +} + +sub isnt { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $got && $got ne $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "not '$expect'"); +} + +sub can_ok { + my ($class, $method) = @_; + $test = $test + 1; + if (eval { $class->can($method) }) { + print "ok $test - $class->can('$method')\n"; + return 1; + } + my @caller = caller; + print "# Failed test at $caller[1] line $caller[2]\n"; + print "# $class cannot $method\n"; + return; +} =pod diff --git a/t/comp/our.t b/t/comp/our.t index 69fbb03..d271fe5 100644 --- a/t/comp/our.t +++ b/t/comp/our.t @@ -1,12 +1,27 @@ #!./perl -BEGIN { - chdir 't'; - @INC = '../lib'; - require './test.pl'; -} - print "1..7\n"; +my $test = 0; + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + + print "not ok $test - $name\n"; + my @caller = caller(0); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expect\n"; + return; +} { package TieAll; diff --git a/t/comp/parser.t b/t/comp/parser.t index 9e1d427..d0e7f5d 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -3,13 +3,52 @@ # Checks if the parser behaves correctly in edge cases # (including weird syntax errors) -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; +print "1..112\n"; + +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; } -BEGIN { require "./test.pl"; } -plan( tests => 112 ); +sub like { + my ($got, $pattern, $name) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test - $name\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern, $name); +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $expect) { + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'", $name); + } else { + if (!defined $got) { + print "ok $test - $name\n"; + return 1; + } + failed($got, 'undef', $name); + } +} eval '%...@x=0;'; like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%...@x=0' ); @@ -109,7 +148,8 @@ my %data = ( foo => "\n" ); print "#"; print( $data{foo}); -pass(); +$test = $test + 1; +print "ok $test\n"; # Bug #21875 # { q.* => ... } should be interpreted as hash, not block @@ -127,7 +167,7 @@ EOF { my ($expect, $eval) = split / /, $line, 2; my $result = eval $eval; - ok($@ eq '', "eval $eval"); + is($@, '', "eval $eval"); is(ref $result, $expect ? 'HASH' : '', $eval); } @@ -160,7 +200,8 @@ EOF # this used to segfault (because $[=1 is optimized away to a null block) my $x; $[ = 1 while $x; - pass(); + $test = $test + 1; + print "ok $test\n"; $[ = 0; # restore the original value for less side-effects } @@ -180,9 +221,11 @@ EOF { my $x; $x = 1 for ($[) = 0; - pass('optimized assignment to $[ used to segfault in list context'); + $test = $test + 1; + print "ok $test - optimized assignment to \$[ used to segfault in list context\n"; if ($[ = 0) { $x = 1 } - pass('optimized assignment to $[ used to segfault in scalar context'); + $test = $test + 1; + print "ok $test - optimized assignment to \$[ used to segfault in scalar context\n"; $x = ($[=2.4); is($x, 2, 'scalar assignment to $[ behaves like other variables'); $x = (($[) = 0); diff --git a/t/comp/require.t b/t/comp/require.t index e7d0da6..c3f0343 100644 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -22,7 +22,7 @@ krunch.pm krunch.pmc whap.pm whap.pmc); my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; -my $total_tests = 47; +my $total_tests = 48; if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } print "1..$total_tests\n"; @@ -93,6 +93,12 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; } +# "use 5.11.0" (and higher) loads strictures. +# check that this doesn't happen with require +eval 'require 5.11.0; ${"foo"} = "bar";'; +print "# $...@\nnot " if $@; +print "ok ",$i++,"\n"; + # interaction with pod (see the eof) write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); require "bleah.pm"; diff --git a/t/comp/retainedlines.t b/t/comp/retainedlines.t index 9d1b40e..8de8237 100644 --- a/t/comp/retainedlines.t +++ b/t/comp/retainedlines.t @@ -2,21 +2,51 @@ # Check that lines from eval are correctly retained by the debugger -BEGIN { - require "./test.pl"; -} - # Uncomment this for testing, but don't leave it in for "production", as # we've not yet verified that use works. # use strict; -plan (tests => 65); +print "1..65\n"; +my $test = 0; + +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $expect) { + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'", $name); + } else { + if (!defined $got) { + print "ok $test - $name\n"; + return 1; + } + failed($got, 'undef', $name); + } +} $^P = 0xA; my @before = grep { /eval/ } keys %::; -is (@before, 0, "No evals"); +is ((scalar @before), 0, "No evals"); my %seen; @@ -27,11 +57,12 @@ sub check_retained_lines { my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::; - is (@keys, 1, "1 new eval"); + is ((scalar @keys), 1, "1 new eval"); my @got_lines = @{$::{$keys[0]}}; - is (@got_lines, @expect_lines, "Right number of lines for $name"); + is ((scalar @got_lines), + (scalar @expect_lines), "Right number of lines for $name"); for (0..$#expect_lines) { is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct"); @@ -65,7 +96,7 @@ for my $sep (' ', "\0") { eval $prog and die; is (eval "$name()", "This is $name", "Subroutine was compiled, despite error") - or diag $@; + or print STDERR "# $...@\n"; check_retained_lines($prog, 'eval that defines subroutine but has syntax error'); @@ -85,7 +116,7 @@ foreach my $flags (0x0, 0x800, 0x1000, 0x1800) { } else { my @after = grep { /eval/ } keys %::; - is (@after, 0 + keys %seen, + is (scalar @after, 0 + keys %seen, "evals that don't define subroutines are correctly cleaned up"); } @@ -96,7 +127,7 @@ foreach my $flags (0x0, 0x800, 0x1000, 0x1800) { } else { my @after = grep { /eval/ } keys %::; - is (@after, 0 + keys %seen, + is (scalar @after, 0 + keys %seen, "evals that fail are correctly cleaned up"); } } diff --git a/t/comp/uproto.t b/t/comp/uproto.t index 9b908eb..c899b68 100644 --- a/t/comp/uproto.t +++ b/t/comp/uproto.t @@ -1,12 +1,52 @@ #!perl -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require "./test.pl"; +print "1..39\n"; +my $test = 0; + +sub failed { + my ($got, $expected) = @_; + + print "not ok $test\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; } -plan(tests => 39); +sub like { + my ($got, $pattern) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern); +} + +sub is { + my ($got, $expect) = @_; + $test = $test + 1; + if (defined $expect) { + if (defined $got && $got eq $expect) { + print "ok $test\n"; + return 1; + } + failed($got, "'$expect'"); + } else { + if (!defined $got) { + print "ok $test\n"; + return 1; + } + failed($got, 'undef'); + } +} sub f($$_) { my $x = shift; is("@_", $x) } @@ -65,7 +105,11 @@ like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); eval q{ sub wrong2 ($__); wrong2(1,2) }; like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); -sub opt ($;_) { is($_[0], "seen"); ok(!defined $_[1], "; has precedence over _") } +sub opt ($;_) { + is($_[0], "seen"); + is($_[1], undef, "; has precedence over _"); +} + opt("seen"); sub unop (_) { is($_[0], 11, "unary op") } diff --git a/t/comp/use.t b/t/comp/use.t index ba7d587..fade9fe 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -6,7 +6,7 @@ BEGIN { $INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm } -print "1..70\n"; +print "1..69\n"; # Can't require test.pl, as we're testing the use/require mechanism here. @@ -122,9 +122,6 @@ is ($@, ""); # and they are properly scoped eval '{use 5.11.0;} ${"foo"} = "bar";'; is ($@, ""); -# and this doesn't happen with require -eval 'require 5.11.0; ${"foo"} = "bar";'; -is ($@, ""); { use test_use } # check that subparse saves pending tokens diff --git a/t/comp/utf.t b/t/comp/utf.t index 0d340f6..6f79d27 100644 --- a/t/comp/utf.t +++ b/t/comp/utf.t @@ -1,8 +1,7 @@ -#!./perl +#!./perl -w -BEGIN { require "./test.pl"; } - -plan(tests => 18); +print "1..18\n"; +my $test = 0; my %templates = ( utf8 => 'C0U', @@ -24,7 +23,14 @@ sub test { print $fh bytes_to_utf($enc, "$tag\n", $bom); close $fh or die $!; my $got = do "./utf$$.pl"; - is($got, $tag); + $test = $test + 1; + if (!defined $got) { + print "not ok $test # $enc $tag $bom; got undef\n"; + } elsif ($got ne $tag) { + print "not ok $test # $enc $tag $bom; got '$got'\n"; + } else { + print "ok $test\n"; + } } for my $bom (0, 1) { diff --git a/t/porting/test_bootstrap.t b/t/porting/test_bootstrap.t new file mode 100644 index 0000000..a1bd63d --- /dev/null +++ b/t/porting/test_bootstrap.t @@ -0,0 +1,47 @@ +#!/perl -w +use strict; + +# See "Writing a test" in perlhack.pod for the instructions about the order that +# testing directories run, and which constructions should be avoided in the +# early tests. + +# This regression tests ensures that the rules aren't accidentally overlooked. + +require './test.pl'; + +plan('no_plan'); + +open my $fh, '<', '../MANIFEST' or die "Can't open MANIFEST: $!"; + +# Three tests in t/comp need to use require or use to get their job done: +my %exceptions = (hints => "require './test.pl'", + parser => 'use DieDieDie', + proto => 'use strict', + ); + +while (my $file = <$fh>) { + next unless $file =~ s!^t/!!; + chomp $file; + $file =~ s/\s+.*//; + next unless $file =~ m!\.t$!; + + local $/; + open my $t, '<', $file or die "Can't open $file: $!"; + my $contents = <$t>; + # Make sure that we don't match ourselves + unlike($contents, qr/use\s+Test::More/, "$file doesn't use Test::\QMore"); + next unless $file =~ m!^base/! or $file =~ m!^comp!; + + # Remove only the excepted constructions for the specific files. + if ($file =~ m!comp/(.*)\.t! && $exceptions{$1}) { + my $allowed = $exceptions{$1}; + $contents =~ s/\Q$allowed//gs; + } + + # All uses of use are allowed in t/comp/use.t + unlike($contents, qr/^\s*use\s+/m, "$file doesn't use use") + unless $file eq 'comp/use.t'; + # All uses of require are allowed in t/comp/require.t + unlike($contents, qr/^\s*require\s+/m, "$file doesn't use require") + unless $file eq 'comp/require.t' +} -- Perl5 Master Repository
