diff options
Diffstat (limited to 'gnu/usr.bin/perl/t')
| -rw-r--r-- | gnu/usr.bin/perl/t/TEST | 44 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/cmd/for.t | 364 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/use.t | 8 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/harness | 3 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/io/open.t | 8 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/delete.t | 15 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/goto.t | 168 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/list.t | 11 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/ref.t | 15 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/sleep.t | 15 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/sort.t | 280 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/taint.t | 39 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/op/tie.t | 1 |
13 files changed, 927 insertions, 44 deletions
diff --git a/gnu/usr.bin/perl/t/TEST b/gnu/usr.bin/perl/t/TEST index 12985b77220..ea9a2413089 100644 --- a/gnu/usr.bin/perl/t/TEST +++ b/gnu/usr.bin/perl/t/TEST @@ -1,7 +1,9 @@ #!./perl # This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. +# most of the constructs we'll be testing for. (This comment is +# probably obsolete on the avoidance side, though still currrent +# on the peculiarity side.) $| = 1; @@ -20,7 +22,8 @@ if ($#ARGV >= 0) { $core = 1 if $1 eq 'core'; $verbose = 1 if $1 eq 'v'; $torture = 1 if $1 eq 'torture'; - $with_utf= 1 if $1 eq 'utf8'; + $with_utf8 = 1 if $1 eq 'utf8'; + $with_utf16 = 1 if $1 eq 'utf16'; $bytecompile = 1 if $1 eq 'bytecompile'; $compile = 1 if $1 eq 'compile'; $taintwarn = 1 if $1 eq 'taintwarn'; @@ -134,6 +137,32 @@ elsif( $compile ) { elsif( $bytecompile ) { _testprogs('bytecompile', '', @ARGV); } +elsif ($with_utf16) { + for my $e (0, 1) { + for my $b (0, 1) { + print STDERR "# ENDIAN $e BOM $b\n"; + my @UARGV; + for my $a (@ARGV) { + my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); + my $f = $e ? "v" : "n"; + push @UARGV, $u; + unlink($u); + if (open(A, $a)) { + if (open(U, ">$u")) { + print U pack("$f", 0xFEFF) if $b; + while (<A>) { + print U pack("$f*", unpack("C*", $_)); + } + close(A); + } + close(B); + } + } + _testprogs('perl', '', @UARGV); + unlink(@UARGV); + } + } +} else { _testprogs('compile', '', @ARGV) if -e "../testcompile"; _testprogs('perl', '', @ARGV); @@ -219,6 +248,9 @@ EOT open(SCRIPT,"<$test") or die "Can't run $test.\n"; $_ = <SCRIPT>; close(SCRIPT) unless ($type eq 'deparse'); + if ($with_utf16) { + $_ =~ tr/\0//d; + } if (/#!.*\bperl.*\s-\w*([tT])/) { $switch = qq{"-$1"}; } @@ -243,7 +275,7 @@ EOT close(SCRIPT); } - my $utf = $with_utf ? '-I../lib -Mutf8' : ''; + my $utf8 = $with_utf8 ? '-I../lib -Mutf8' : ''; my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC if ($type eq 'deparse') { my $deparse = @@ -275,7 +307,7 @@ EOT my $bytecompile = "$perl $testswitch $switch -I../lib $bswitch". "-o$test.plc $test 2>$null &&". - "$perl $testswitch $switch -I../lib $utf $test.plc |"; + "$perl $testswitch $switch -I../lib $utf8 $test.plc |"; open(RESULTS,$bytecompile) or print "can't byte-compile '$bytecompile': $!.\n"; } @@ -288,7 +320,7 @@ EOT . "--num-callers=50 --logfile-fd=3 $perl"; $redir = "3>$valgrind_log"; } - my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|"; + my $run = "$perl" . _quote_args("$testswitch $switch $utf8") . " $test $redir|"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } else { @@ -296,7 +328,7 @@ EOT my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " . # -O9 for good measure, -fcog is broken ATM "$switch -Wb=-O9,-fno-cog -L .. " . - "-I \".. ../lib/CORE\" $args $utf $test -o "; + "-I \".. ../lib/CORE\" $args $utf8 $test -o "; if( $^O eq 'MSWin32' ) { $test_executable = "$test.exe"; diff --git a/gnu/usr.bin/perl/t/cmd/for.t b/gnu/usr.bin/perl/t/cmd/for.t index 27fb5a25178..0814e7bb236 100644 --- a/gnu/usr.bin/perl/t/cmd/for.t +++ b/gnu/usr.bin/perl/t/cmd/for.t @@ -1,6 +1,6 @@ #!./perl -print "1..14\n"; +print "1..78\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; @@ -95,3 +95,365 @@ print $@ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n"; print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n"; } +# A lot of tests to check that reversed for works. +my $test = 14; +sub is { + my ($got, $expected, $name) = @_; + ++$test; + if ($got eq $expected) { + print "ok $test # $name\n"; + return 1; + } + print "not ok $test # $name\n"; + print "# got '$got', expected '$expected'\n"; + return 0; +} + +@array = ('A', 'B', 'C'); +for (@array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array'); +$r = ''; +for (1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list'); +$r = ''; +for (map {$_} @array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array via map'); +$r = ''; +for (map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via map'); + +$r = ''; +for (reverse @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array'); +$r = ''; +for (reverse 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list'); +$r = ''; +for (reverse map {$_} @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array via map'); +$r = ''; +for (reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via map'); + +$r = ''; +for my $i (@array) { + $r .= $i; +} +is ($r, 'ABC', 'Forwards for array with var'); +$r = ''; +for my $i (1,2,3) { + $r .= $i; +} +is ($r, '123', 'Forwards for list with var'); +$r = ''; +for my $i (map {$_} @array) { + $r .= $i; +} +is ($r, 'ABC', 'Forwards for array via map with var'); +$r = ''; +for my $i (map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '123', 'Forwards for list via map with var'); + +$r = ''; +for my $i (reverse @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array with var'); +$r = ''; +for my $i (reverse 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list with var'); +$r = ''; +for my $i (reverse map {$_} @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array via map with var'); +$r = ''; +for my $i (reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via map with var'); + +# For some reason the generate optree is different when $_ is implicit. +$r = ''; +for $_ (@array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array with explicit $_'); +$r = ''; +for $_ (1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list with explicit $_'); +$r = ''; +for $_ (map {$_} @array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array via map with explicit $_'); +$r = ''; +for $_ (map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via map with explicit $_'); + +$r = ''; +for $_ (reverse @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array with explicit $_'); +$r = ''; +for $_ (reverse 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list with explicit $_'); +$r = ''; +for $_ (reverse map {$_} @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array via map with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via map with explicit $_'); + +# I don't think that my is that different from our in the optree. But test a +# few: +$r = ''; +for our $i (reverse @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array with our var'); +$r = ''; +for our $i (reverse 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list with our var'); +$r = ''; +for our $i (reverse map {$_} @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array via map with our var'); +$r = ''; +for our $i (reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via map with our var'); + + +$r = ''; +for (1, reverse @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array with leading value'); +$r = ''; +for ('A', reverse 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list with leading value'); +$r = ''; +for (1, reverse map {$_} @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array via map with leading value'); +$r = ''; +for ('A', reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via map with leading value'); + +$r = ''; +for (reverse (@array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array with trailing value'); +$r = ''; +for (reverse (1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list with trailing value'); +$r = ''; +for (reverse (map {$_} @array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array via map with trailing value'); +$r = ''; +for (reverse (map {$_} 1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list via map with trailing value'); + + +$r = ''; +for $_ (1, reverse @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array with leading value with explicit $_'); +$r = ''; +for $_ ('A', reverse 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list with leading value with explicit $_'); +$r = ''; +for $_ (1, reverse map {$_} @array) { + $r .= $_; +} +is ($r, '1CBA', + 'Reverse for array via map with leading value with explicit $_'); +$r = ''; +for $_ ('A', reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_'); + +$r = ''; +for $_ (reverse (@array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} @array), 1) { + $r .= $_; +} +is ($r, 'CBA1', + 'Reverse for array via map with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} 1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', + 'Reverse for list via map with trailing value with explicit $_'); + +$r = ''; +for my $i (1, reverse @array) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array with leading value and var'); +$r = ''; +for my $i ('A', reverse 1,2,3) { + $r .= $i; +} +is ($r, 'A321', 'Reverse for list with leading value and var'); +$r = ''; +for my $i (1, reverse map {$_} @array) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array via map with leading value and var'); +$r = ''; +for my $i ('A', reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, 'A321', 'Reverse for list via map with leading value and var'); + +$r = ''; +for my $i (reverse (@array), 1) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for array with trailing value and var'); +$r = ''; +for my $i (reverse (1,2,3), 'A') { + $r .= $i; +} +is ($r, '321A', 'Reverse for list with trailing value and var'); +$r = ''; +for my $i (reverse (map {$_} @array), 1) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for array via map with trailing value and var'); +$r = ''; +for my $i (reverse (map {$_} 1,2,3), 'A') { + $r .= $i; +} +is ($r, '321A', 'Reverse for list via map with trailing value and var'); + + +$r = ''; +for (reverse 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array'); +$r = ''; +for (reverse map {$_} 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array via map'); + +$r = ''; +for (reverse (@array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value'); +$r = ''; +for (reverse (map {$_} @array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value via map'); + +$r = ''; +for $_ (reverse 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_'); + +$r = ''; +for $_ (reverse (@array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} @array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value via map with explicit $_'); + + +$r = ''; +for my $i (reverse 1, @array) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for value and array with var'); +$r = ''; +for my $i (reverse map {$_} 1, @array) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for value and array via map with var'); + +$r = ''; +for my $i (reverse (@array, 1)) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array and value with var'); +$r = ''; +for my $i (reverse (map {$_} @array, 1)) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array and value via map with var'); diff --git a/gnu/usr.bin/perl/t/comp/use.t b/gnu/usr.bin/perl/t/comp/use.t index 8e9eb8b1a80..0bb8b65b36a 100644 --- a/gnu/usr.bin/perl/t/comp/use.t +++ b/gnu/usr.bin/perl/t/comp/use.t @@ -22,7 +22,7 @@ if ($@) { } print "ok ",$i++,"\n"; -eval sprintf "use %.5f;", $]; +eval sprintf "use %.6f;", $]; if ($@) { print STDERR $@,"\n"; print "not "; @@ -30,20 +30,20 @@ if ($@) { print "ok ",$i++,"\n"; -eval sprintf "use %.5f;", $] - 0.000001; +eval sprintf "use %.6f;", $] - 0.000001; if ($@) { print STDERR $@,"\n"; print "not "; } print "ok ",$i++,"\n"; -eval sprintf("use %.5f;", $] + 1); +eval sprintf("use %.6f;", $] + 1); unless ($@) { print "not "; } print "ok ",$i++,"\n"; -eval sprintf "use %.5f;", $] + 0.00001; +eval sprintf "use %.6f;", $] + 0.00001; unless ($@) { print "not "; } diff --git a/gnu/usr.bin/perl/t/harness b/gnu/usr.bin/perl/t/harness index f7239fe3b17..e745db8a34d 100644 --- a/gnu/usr.bin/perl/t/harness +++ b/gnu/usr.bin/perl/t/harness @@ -47,6 +47,9 @@ foreach (keys %datahandle) { my @tests = (); +# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV +@ARGV = grep $_ && length( $_ ) => @ARGV; + if (@ARGV) { if ($^O eq 'MSWin32') { @tests = map(glob($_),@ARGV); diff --git a/gnu/usr.bin/perl/t/io/open.t b/gnu/usr.bin/perl/t/io/open.t index 5e1b5ec80d4..e12b4475d1a 100644 --- a/gnu/usr.bin/perl/t/io/open.t +++ b/gnu/usr.bin/perl/t/io/open.t @@ -12,7 +12,7 @@ use Config; $Is_VMS = $^O eq 'VMS'; $Is_MacOS = $^O eq 'MacOS'; -plan tests => 107; +plan tests => 108; my $Perl = which_perl(); @@ -315,3 +315,9 @@ fresh_perl_is( 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 'ok', { stderr => 1 }, '#29102: Crash on assignment to lexical filehandle'); + +# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise +# an exception + +eval { open $99, "foo" }; +like($@, qr/Modification of a read-only value attempted/, "readonly fh"); diff --git a/gnu/usr.bin/perl/t/op/delete.t b/gnu/usr.bin/perl/t/op/delete.t index 53212a11407..ac4405c4193 100644 --- a/gnu/usr.bin/perl/t/op/delete.t +++ b/gnu/usr.bin/perl/t/op/delete.t @@ -1,6 +1,6 @@ #!./perl -print "1..37\n"; +print "1..38\n"; # delete() on hash elements @@ -129,3 +129,16 @@ print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; print "not " if defined $y; print "ok 37\n"; } + +{ + # [perl #30733] array delete didn't free returned element + my $x = 0; + sub X::DESTROY { $x++ } + { + my @a; + $a[0] = bless [], 'X'; + my $y = delete $a[0]; + } + print "not " unless $x == 1; + print "ok 38\n"; +} diff --git a/gnu/usr.bin/perl/t/op/goto.t b/gnu/usr.bin/perl/t/op/goto.t index 859d5a66ee3..3b921238f21 100644 --- a/gnu/usr.bin/perl/t/op/goto.t +++ b/gnu/usr.bin/perl/t/op/goto.t @@ -7,10 +7,12 @@ BEGIN { @INC = qw(. ../lib); } -print "1..33\n"; +print "1..47\n"; require "test.pl"; +$purpose; # update per test, and include in print ok's ! + while ($?) { $foo = 1; label1: @@ -64,7 +66,9 @@ FINALE: print "ok 13\n"; # does goto LABEL handle block contexts correctly? - +$purpose = 'handles block contexts correctly (does scope-hopping)'; +# note that this scope-hopping differs from last & next, +# which always go up-scope strictly. my $cond = 1; for (1) { if ($cond == 1) { @@ -74,12 +78,12 @@ for (1) { elsif ($cond == 0) { OTHER: $cond = 2; - print "ok 14\n"; + print "ok 14 - $purpose\n"; goto THIRD; } else { THIRD: - print "ok 15\n"; + print "ok 15 - $purpose\n"; } } print "ok 16\n"; @@ -87,56 +91,58 @@ print "ok 16\n"; # Does goto work correctly within a for(;;) loop? # (BUG ID 20010309.004) +$purpose = 'goto inside a for(;;) loop body from inside the body'; for(my $i=0;!$i++;) { my $x=1; goto label; - label: print (defined $x?"ok ": "not ok ", "17\n") + label: print (defined $x?"ok ": "not ok ", "17 - $purpose\n") } # Does goto work correctly going *to* a for(;;) loop? # (make sure it doesn't skip the initializer) +$purpose = 'goto a for(;;) loop, from outside (does initializer)'; my ($z, $y) = (0); -FORL1: for($y="ok 18\n"; $z;) {print $y; goto TEST19} -($y,$z) = ("not ok 18\n", 1); +FORL1: for($y="ok 18 - $purpose\n"; $z;) {print $y; goto TEST19} +($y,$z) = ("not ok 18 - $purpose\n", 1); goto FORL1; # Even from within the loop? - TEST19: $z = 0; -FORL2: for($y="ok 19\n"; 1;) { +$purpose = 'goto a for(;;) loop, from inside (does initializer)'; +FORL2: for($y="ok 19 - $purpose\n"; 1;) { if ($z) { print $y; last; } - ($y, $z) = ("not ok 19\n", 1); + ($y, $z) = ("not ok 19 - $purpose\n", 1); goto FORL2; } # Does goto work correctly within a try block? # (BUG ID 20000313.004) - +$purpose = 'works correctly within a try block'; my $ok = 0; eval { my $variable = 1; goto LABEL20; LABEL20: $ok = 1 if $variable; }; -print ($ok&&!$@ ? "ok 20\n" : "not ok 20\n"); +print ($ok&&!$@ ? "ok 20" : "not ok 20", " - $purpose\n"); # And within an eval-string? - - +$purpose = 'works correctly within an eval string'; $ok = 0; eval q{ my $variable = 1; goto LABEL21; LABEL21: $ok = 1 if $variable; }; -print ($ok&&!$@ ? "ok 21\n" : "not ok 21\n"); +print ($ok&&!$@ ? "ok" : "not ok", " 21 - $purpose\n"); # Test that goto works in nested eval-string +$purpose = 'works correctly in a nested eval string'; $ok = 0; {eval q{ eval q{ @@ -149,7 +155,7 @@ $ok = 0; }; $ok = 0 if $@; } -print ($ok ? "ok 22\n" : "not ok 22\n"); +print ($ok ? "ok" : "not ok", " 22 - $purpose\n"); { my $false = 0; @@ -241,19 +247,21 @@ my $r = runperl( print "not " if $r ne "ok\n"; print "ok 33 - avoid pad without an \@_\n"; - +goto moretests; exit; bypass: -print "ok 5\n"; +$purpose = 'eval "goto $x"'; +print "ok 5 - $purpose\n"; # Test autoloading mechanism. sub two { ($pack, $file, $line) = caller; # Should indicate original call stats. + $purpose = 'autoloading mechanism.'; print "@_ $pack $file $line" eq "1 2 3 main $FILE $LINE" - ? "ok 7\n" - : "not ok 7\n"; + ? "ok 7 - $purpose\n" + : "not ok 7 - $purpose\n"; } sub one { @@ -267,9 +275,11 @@ $FILE = __FILE__; $LINE = __LINE__ + 1; &one(1,2,3); +$purpose = 'goto NOWHERE sets $@'; $wherever = NOWHERE; eval { goto $wherever }; -print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n"; +print $@ =~ /Can't find label NOWHERE/ + ? "ok 8 - $purpose\n" : "not ok 8 - $purpose\n"; #' # see if a modified @_ propagates { @@ -290,3 +300,119 @@ auto("ok 12\n"); $wherever = FINALE; goto $wherever; + +moretests: +# test goto duplicated labels. +{ + my $z = 0; + $purpose = "catch goto middle of foreach"; + eval { + $z = 0; + for (0..1) { + L4: # not outer scope + $z += 10; + last; + } + goto L4 if $z == 10; + last; + }; + print ($@ =~ /Can't "goto" into the middle of a foreach loop/ #' + ? "ok" : "not ok", " 34 - $purpose\n"); + + $z = 0; + # ambiguous label resolution (outer scope means endless loop!) + $purpose = "prefer same scope (loop body) to outer scope (loop entry)"; + L1: + for my $x (0..1) { + $z += 10; + print $z == 10 ? "" : "not ", "ok 35 - $purpose\n"; + goto L1 unless $x; + $z += 10; + L1: + print $z == 10 ? "" : "not ", "ok 36 - $purpose\n"; + last; + } + + $purpose = "prefer this scope (block body) to outer scope (block entry)"; + $z = 0; + L2: + { + $z += 10; + print $z == 10 ? "" : "not ", "ok 37 - $purpose\n"; + goto L2 if $z == 10; + $z += 10; + L2: + print $z == 10 ? "" : "not ", "ok 38 - $purpose\n"; + } + + + { + $purpose = "prefer this scope to inner scope"; + $z = 0; + while (1) { + L3: # not inner scope + $z += 10; + last; + } + print $z == 10 ? "": "not ", "ok 39 - $purpose\n"; + goto L3 if $z == 10; + $z += 10; + L3: # this scope ! + print $z == 10 ? "" : "not ", "ok 40 - $purpose\n"; + } + + L4: # not outer scope + { + $purpose = "prefer this scope to inner,outer scopes"; + $z = 0; + while (1) { + L4: # not inner scope + $z += 1; + last; + } + print $z == 1 ? "": "not ", "ok 41 - $purpose\n"; + goto L4 if $z == 1; + $z += 10; + L4: # this scope ! + print $z == 1 ? "": "not ", "ok 42 - $purpose\n"; + } + + { + $purpose = "same label, multiple times in same scope (choose 1st)"; + my $tnum = 43; + my $loop; + for $x (0..1) { + L2: # without this, fails 1 (middle) out of 3 iterations + $z = 0; + L2: + $z += 10; + print $z == 10 ? "": "not ", "ok $tnum - $purpose\n"; + $tnum++; + goto L2 if $z == 10 and not $loop++; + } + } +} + +# deep recursion with gotos eventually caused a stack reallocation +# which messed up buggy internals that didn't expect the stack to move + +sub recurse1 { + unshift @_, "x"; + goto &recurse2; +} +sub recurse2 { + $x = shift; + $_[0] ? +1 + recurse1($_[0] - 1) : 0 +} +print "not " unless recurse1(500) == 500; +print "ok 46 - recursive goto &foo\n"; + +# [perl #32039] Chained goto &sub drops data too early. + +sub a32039 { @_=("foo"); goto &b32039; } +sub b32039 { goto &c32039; } +sub c32039 { print $_[0] eq 'foo' ? "" : "not ", "ok 47 - chained &goto\n" } +a32039(); + + + diff --git a/gnu/usr.bin/perl/t/op/list.t b/gnu/usr.bin/perl/t/op/list.t index 4d7a2d5444b..89ccf02c10a 100644 --- a/gnu/usr.bin/perl/t/op/list.t +++ b/gnu/usr.bin/perl/t/op/list.t @@ -1,6 +1,6 @@ #!./perl -print "1..28\n"; +print "1..30\n"; @foo = (1, 2, 3, 4); if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} @@ -86,4 +86,13 @@ for ($x = 0; $x < 3; $x++) { my @c = (0, undef, undef, 3)[1, 2]; print "not " unless @b == @c and @c == 2; print "ok 28\n"; + + @b = (29, scalar @c[()]); + print "not " if join(':',@b) ne '29:'; + print "ok 29\n"; + + my %h = (a => 1); + @b = (30, scalar @h{()}); + print "not " if join(':',@b) ne '30:'; + print "ok 30\n"; } diff --git a/gnu/usr.bin/perl/t/op/ref.t b/gnu/usr.bin/perl/t/op/ref.t index 597e03698c9..a59af93d997 100644 --- a/gnu/usr.bin/perl/t/op/ref.t +++ b/gnu/usr.bin/perl/t/op/ref.t @@ -5,7 +5,7 @@ BEGIN { @INC = qw(. ../lib); } -print "1..69\n"; +print "1..70\n"; require 'test.pl'; @@ -368,6 +368,18 @@ print "not " if length $result; print "ok ",++$test," - freeing self-referential typeglob\n"; print "# got: $result\n" if length $result; +# using a regex in the destructor for STDOUT segfaulted because the +# REGEX pad had already been freed (ithreads build only). The +# object is required to trigger the early freeing of GV refs to to STDOUT + +$result = runperl( + prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', + stderr => 1 +); +print "not " unless $result =~ /^(ok)+$/; +print "ok ",++$test," - STDOUT destructor\n"; +print "# got: $result\n" unless $result =~ /^(ok)+$/; + # test global destruction ++$test; @@ -386,3 +398,4 @@ package FINALE; DESTROY { print $_[0][0]; } + diff --git a/gnu/usr.bin/perl/t/op/sleep.t b/gnu/usr.bin/perl/t/op/sleep.t index 5f6c4c0bbbe..c2684ad37c0 100644 --- a/gnu/usr.bin/perl/t/op/sleep.t +++ b/gnu/usr.bin/perl/t/op/sleep.t @@ -1,8 +1,15 @@ #!./perl -# $RCSfile: sleep.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:23 $ +use strict; +use warnings; +use Test::More tests=>4; -print "1..1\n"; +my $start = time; +my $sleep_says = sleep 3; +my $diff = time - $start; -$x = sleep 3; -if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";} +cmp_ok( $sleep_says, '>=', 2, 'Sleep says it slept at least 2 seconds' ); +cmp_ok( $sleep_says, '<=', 10, '... and no more than 10' ); + +cmp_ok( $diff, '>=', 2, 'Actual time diff is at least 2 seconds' ); +cmp_ok( $diff, '<=', 10, '... and no more than 10' ); diff --git a/gnu/usr.bin/perl/t/op/sort.t b/gnu/usr.bin/perl/t/op/sort.t index c1129c2422f..bdb48856b94 100644 --- a/gnu/usr.bin/perl/t/op/sort.t +++ b/gnu/usr.bin/perl/t/op/sort.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } use warnings; -print "1..75\n"; +print "1..129\n"; # these shouldn't hang { @@ -22,7 +22,7 @@ sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; # Beware: in future this may become hairier because of possible -# collation complications: qw(A a B c) can be sorted at least as +# collation complications: qw(A a B b) can be sorted at least as # any of the following # # A a B b @@ -391,6 +391,282 @@ sub ok { ok "@a", "c b a x", "un-inplace sort with function of lexical 2"; } +# Test optimisations of reversed sorts. As we now guarantee stability by +# default, # optimisations which do not provide this are bogus. +{ + package Oscalar; + use overload (qw("" stringify 0+ numify fallback 1)); + + sub new { + bless [$_[1], $_[2]], $_[0]; + } + + sub stringify { $_[0]->[0] } + + sub numify { $_[0]->[1] } +} + +sub generate { + my $count = 0; + map {new Oscalar $_, $count++} qw(A A A B B B C C C); +} + +my @input = &generate; +my @output = sort @input; +ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort"; + +@input = &generate; +@input = sort @input; +ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", + "Simple stable in place sort"; + +# This won't be very interesting +@input = &generate; +@output = sort {$a <=> $b} @input; +ok "@output", "A A A B B B C C C", 'stable $a <=> $b sort'; + +@input = &generate; +@output = sort {$a cmp $b} @input; +ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort'; + +@input = &generate; +@input = sort {$a cmp $b} @input; +ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", + 'stable $a cmp $b in place sort'; + +@input = &generate; +@output = sort {$b cmp $a} @input; +ok join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort'; + +@input = &generate; +@input = sort {$b cmp $a} @input; +ok join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2", + 'stable $b cmp $a in place sort'; + +@input = &generate; +@output = reverse sort @input; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort"; + +@input = &generate; +@input = reverse sort @input; +ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", + "Reversed stable in place sort"; + +@input = &generate; +my $output = reverse sort @input; +ok $output, "CCCBBBAAA", "Reversed stable sort in scalar context"; + + +@input = &generate; +@output = reverse sort {$a cmp $b} @input; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", + 'reversed stable $a cmp $b sort'; + +@input = &generate; +@input = reverse sort {$a cmp $b} @input; +ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", + 'revesed stable $a cmp $b in place sort'; + +@input = &generate; +$output = reverse sort {$a cmp $b} @input; +ok $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context'; + +@input = &generate; +@output = reverse sort {$b cmp $a} @input; +ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", + 'reversed stable $b cmp $a sort'; + +@input = &generate; +@input = reverse sort {$b cmp $a} @input; +ok join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6", + 'revesed stable $b cmp $a in place sort'; + +@input = &generate; +$output = reverse sort {$b cmp $a} @input; +ok $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context'; + +sub stuff { + # Something complex enough to defeat any constant folding optimiser + $$ - $$; +} + +@input = &generate; +@output = reverse sort {stuff || $a cmp $b} @input; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", + 'reversed stable complex sort'; + +@input = &generate; +@input = reverse sort {stuff || $a cmp $b} @input; +ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", + 'revesed stable complex in place sort'; + +@input = &generate; +$output = reverse sort {stuff || $a cmp $b } @input; +ok $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context'; + +sub sortr { + reverse sort @_; +} + +@output = sortr &generate; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", + 'reversed stable sort return list context'; +$output = sortr &generate; +ok $output, "CCCBBBAAA", + 'reversed stable sort return scalar context'; + +sub sortcmpr { + reverse sort {$a cmp $b} @_; +} + +@output = sortcmpr &generate; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", + 'reversed stable $a cmp $b sort return list context'; +$output = sortcmpr &generate; +ok $output, "CCCBBBAAA", + 'reversed stable $a cmp $b sort return scalar context'; + +sub sortcmprba { + reverse sort {$b cmp $a} @_; +} + +@output = sortcmprba &generate; +ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", + 'reversed stable $b cmp $a sort return list context'; +$output = sortcmprba &generate; +ok $output, "AAABBBCCC", +'reversed stable $b cmp $a sort return scalar context'; + +sub sortcmprq { + reverse sort {stuff || $a cmp $b} @_; +} + +@output = sortcmpr &generate; +ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", + 'reversed stable complex sort return list context'; +$output = sortcmpr &generate; +ok $output, "CCCBBBAAA", + 'reversed stable complex sort return scalar context'; + +# And now with numbers + +sub generate1 { + my $count = 'A'; + map {new Oscalar $count++, $_} 0, 0, 0, 1, 1, 1, 2, 2, 2; +} + +# This won't be very interesting +@input = &generate1; +@output = sort {$a cmp $b} @input; +ok "@output", "A B C D E F G H I", 'stable $a cmp $b sort'; + +@input = &generate1; +@output = sort {$a <=> $b} @input; +ok "@output", "A B C D E F G H I", 'stable $a <=> $b sort'; + +@input = &generate1; +@input = sort {$a <=> $b} @input; +ok "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort'; + +@input = &generate1; +@output = sort {$b <=> $a} @input; +ok "@output", "G H I D E F A B C", 'stable $b <=> $a sort'; + +@input = &generate1; +@input = sort {$b <=> $a} @input; +ok "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort'; + +# test that optimized {$b cmp $a} and {$b <=> $a} remain stable +# (new in 5.9) without overloading +{ no warnings; +@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/; +ok "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ; +@input = sort {$b <=> $a} @input; +ok "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ; +}; + +# These two are actually doing string cmp on 0 1 and 2 +@input = &generate1; +@output = reverse sort @input; +ok "@output", "I H G F E D C B A", "Reversed stable sort"; + +@input = &generate1; +@input = reverse sort @input; +ok "@input", "I H G F E D C B A", "Reversed stable in place sort"; + +@input = &generate1; +$output = reverse sort @input; +ok $output, "IHGFEDCBA", "Reversed stable sort in scalar context"; + +@input = &generate1; +@output = reverse sort {$a <=> $b} @input; +ok "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort'; + +@input = &generate1; +@input = reverse sort {$a <=> $b} @input; +ok "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort'; + +@input = &generate1; +$output = reverse sort {$a <=> $b} @input; +ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context'; + +@input = &generate1; +@output = reverse sort {$b <=> $a} @input; +ok "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort'; + +@input = &generate1; +@input = reverse sort {$b <=> $a} @input; +ok "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort'; + +@input = &generate1; +$output = reverse sort {$b <=> $a} @input; +ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context'; + +@input = &generate1; +@output = reverse sort {stuff || $a <=> $b} @input; +ok "@output", "I H G F E D C B A", 'reversed stable complex sort'; + +@input = &generate1; +@input = reverse sort {stuff || $a <=> $b} @input; +ok "@input", "I H G F E D C B A", 'revesed stable complex in place sort'; + +@input = &generate1; +$output = reverse sort {stuff || $a <=> $b} @input; +ok $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context'; + +sub sortnumr { + reverse sort {$a <=> $b} @_; +} + +@output = sortnumr &generate1; +ok "@output", "I H G F E D C B A", + 'reversed stable $a <=> $b sort return list context'; +$output = sortnumr &generate1; +ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context'; + +sub sortnumrba { + reverse sort {$b <=> $a} @_; +} + +@output = sortnumrba &generate1; +ok "@output", "C B A F E D I H G", + 'reversed stable $b <=> $a sort return list context'; +$output = sortnumrba &generate1; +ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context'; + +sub sortnumrq { + reverse sort {stuff || $a <=> $b} @_; +} + +@output = sortnumrq &generate1; +ok "@output", "I H G F E D C B A", + 'reversed stable complex sort return list context'; +$output = sortnumrq &generate1; +ok $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context'; +@output = reverse (sort(qw(C A B)), 0); +ok "@output", "0 C B A", 'reversed sort with trailing argument'; +@output = reverse (0, sort(qw(C A B))); +ok "@output", "C B A 0", 'reversed sort with leading argument'; diff --git a/gnu/usr.bin/perl/t/op/taint.t b/gnu/usr.bin/perl/t/op/taint.t index f37f3aaae3a..ce436eeb66a 100644 --- a/gnu/usr.bin/perl/t/op/taint.t +++ b/gnu/usr.bin/perl/t/op/taint.t @@ -16,6 +16,7 @@ use strict; use Config; use File::Spec::Functions; +my $total_tests = 236; my $test = 177; sub ok ($;$) { my($ok, $name) = @_; @@ -124,7 +125,7 @@ my $echo = "$Invoke_Perl $ECHO"; my $TEST = catfile(curdir(), 'TEST'); -print "1..223\n"; +print "1..$total_tests\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -1041,3 +1042,39 @@ else eval '$^O = $^X'; test 223, $@ =~ /Insecure dependency in/; } + +EFFECTIVELY_CONSTANTS: { + my $tainted_number = 12 + $TAINT0; + test 224, tainted( $tainted_number ); + + # Even though it's always 0, it's still tainted + my $tainted_product = $tainted_number * 0; + test 225, tainted( $tainted_product ); + test 226, $tainted_product == 0; +} + +TERNARY_CONDITIONALS: { + my $tainted_true = $TAINT . "blah blah blah"; + my $tainted_false = $TAINT0; + test 227, tainted( $tainted_true ); + test 228, tainted( $tainted_false ); + + my $result = $tainted_true ? "True" : "False"; + test 229, $result eq "True"; + test 230, !tainted( $result ); + + $result = $tainted_false ? "True" : "False"; + test 231, $result eq "False"; + test 232, !tainted( $result ); + + my $untainted_whatever = "The Fabulous Johnny Cash"; + my $tainted_whatever = "Soft Cell" . $TAINT; + + $result = $tainted_true ? $tainted_whatever : $untainted_whatever; + test 233, $result eq "Soft Cell"; + test 234, tainted( $result ); + + $result = $tainted_false ? $tainted_whatever : $untainted_whatever; + test 235, $result eq "The Fabulous Johnny Cash"; + test 236, !tainted( $result ); +} diff --git a/gnu/usr.bin/perl/t/op/tie.t b/gnu/usr.bin/perl/t/op/tie.t index 51c4b3a5b85..bd5d079a60d 100644 --- a/gnu/usr.bin/perl/t/op/tie.t +++ b/gnu/usr.bin/perl/t/op/tie.t @@ -294,7 +294,6 @@ sub FETCH { *a = \1; 1 } tie $a, 'main'; print $a; EXPECT -Tied variable freed while still in use at - line 6. ######## # [20020716.007] - nested FETCHES |