diff options
Diffstat (limited to 't')
| -rwxr-xr-x | t/io/argv.t | 5 | ||||
| -rw-r--r-- | t/io/crlf_through.t | 1 | ||||
| -rwxr-xr-x | t/io/dup.t | 1 | ||||
| -rwxr-xr-x | t/io/fs.t | 35 | ||||
| -rw-r--r-- | t/io/layers.t | 2 | ||||
| -rwxr-xr-x | t/io/pipe.t | 3 | ||||
| -rwxr-xr-x | t/io/print.t | 14 | ||||
| -rw-r--r-- | t/io/through.t | 15 | ||||
| -rw-r--r-- | t/lib/1_compile.t | 4 | ||||
| -rwxr-xr-x | t/op/array.t | 2 | ||||
| -rwxr-xr-x | t/op/chop.t | 13 | ||||
| -rwxr-xr-x | t/op/closure.t | 13 | ||||
| -rwxr-xr-x | t/op/index.t | 16 | ||||
| -rwxr-xr-x | t/op/list.t | 6 | ||||
| -rwxr-xr-x | t/op/magic.t | 9 | ||||
| -rwxr-xr-x | t/op/pat.t | 13 | ||||
| -rwxr-xr-x | t/op/sleep.t | 9 | ||||
| -rwxr-xr-x | t/op/sort.t | 3 | ||||
| -rwxr-xr-x | t/op/sprintf.t | 46 | ||||
| -rw-r--r-- | t/op/threads.t | 98 | ||||
| -rw-r--r-- | t/run/runenv.t | 2 | ||||
| -rw-r--r-- | t/test.pl | 3 |
22 files changed, 252 insertions, 61 deletions
diff --git a/t/io/argv.t b/t/io/argv.t index 33c4f1a8e7..8a63c65833 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -72,7 +72,10 @@ undef $^I; ok( eof TRY ); -ok( eof NEVEROPENED, 'eof() true on unopened filehandle' ); +{ + no warnings 'once'; + ok( eof NEVEROPENED, 'eof() true on unopened filehandle' ); +} open STDIN, 'Io_argv1.tmp' or die $!; @ARGV = (); diff --git a/t/io/crlf_through.t b/t/io/crlf_through.t index 3a5522a76e..c08099598e 100644 --- a/t/io/crlf_through.t +++ b/t/io/crlf_through.t @@ -5,5 +5,6 @@ BEGIN { @INC = '../lib'; } +no warnings 'once'; $main::use_crlf = 1; do './io/through.t' or die "no kid script"; diff --git a/t/io/dup.t b/t/io/dup.t index 8247b8e6ef..48497fd232 100755 --- a/t/io/dup.t +++ b/t/io/dup.t @@ -7,6 +7,7 @@ BEGIN { } use Config; +no warnings 'once'; my $test = 1; print "1..26\n"; @@ -47,7 +47,7 @@ $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); my $skip_mode_checks = $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; -plan tests => 42; +plan tests => 44; if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { @@ -78,10 +78,10 @@ SKIP: { is((umask(0)&0777), 022, 'umask'), } -open(fh,'>x') || die "Can't create x"; -close(fh); -open(fh,'>a') || die "Can't create a"; -close(fh); +open(FH,'>x') || die "Can't create x"; +close(FH); +open(FH,'>a') || die "Can't create a"; +close(FH); my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks); @@ -171,10 +171,16 @@ SKIP: { ok(open(my $fh, "<", "a"), "open a"); is(chmod(0, $fh), 1, "fchmod"); $mode = (stat "a")[2]; - is($mode & 0777, 0, "perm reset"); + SKIP: { + skip "no mode checks", 1 if $skip_mode_checks; + is($mode & 0777, 0, "perm reset"); + } is(chmod($newmode, "a"), 1, "fchmod"); $mode = (stat $fh)[2]; - is($mode & 0777, $newmode, "perm restored"); + SKIP: { + skip "no mode checks", 1 if $skip_mode_checks; + is($mode & 0777, $newmode, "perm restored"); + } } SKIP: { @@ -380,8 +386,8 @@ SKIP: { if $^O eq 'cygwin'; chdir './tmp'; - open(fh,'>x') || die "Can't create x"; - close(fh); + open(FH,'>x') || die "Can't create x"; + close(FH); rename('x', 'X'); # this works on win32 only, because fs isn't casesensitive @@ -403,5 +409,16 @@ if ($^O eq 'VMS') { ok(-d 'tmp1', "rename on directories working"); +{ + # Change 26011: Re: A surprising segfault + # to make sure only that these obfuscated sentences will not crash. + + map chmod(+()), ('')x68; + ok(1, "extend sp in pp_chmod"); + + map chown(+()), ('')x68; + ok(1, "extend sp in pp_chown"); +} + # need to remove 'tmp' if rename() in test 28 failed! END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; } diff --git a/t/io/layers.t b/t/io/layers.t index 5fcb4f633f..62f77e864a 100644 --- a/t/io/layers.t +++ b/t/io/layers.t @@ -40,6 +40,8 @@ if (${^UNICODE} & 1) { # Unconditional $UNICODE_STDIN = 1; } +} else { + $UNICODE_STDIN = 0; } my $NTEST = 44 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0) + $UNICODE_STDIN; diff --git a/t/io/pipe.t b/t/io/pipe.t index c32f3b1046..fd355124fe 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -182,7 +182,8 @@ is($?, 42, 'status unaffected by implicit close'); $? = 0; # check that child is reaped if the piped program can't be executed -{ +SKIP: { + skip "/no_such_process exists", 1 if -e "/no_such_process"; open NIL, '/no_such_process |'; close NIL; diff --git a/t/io/print.t b/t/io/print.t index 31d559aac9..65c7117404 100755 --- a/t/io/print.t +++ b/t/io/print.t @@ -9,7 +9,7 @@ use strict 'vars'; eval 'use Errno'; die $@ if $@ and !$ENV{PERL_CORE_MINITEST}; -print "1..19\n"; +print "1..21\n"; my $foo = 'STDOUT'; print $foo "ok 1\n"; @@ -52,3 +52,15 @@ if (!exists &Errno::EBADF) { print "not " if ($! != &Errno::EBADF); print "ok 19\n"; } + +{ + # Change 26009: pp_print didn't extend the stack + # before pushing its return value + # to make sure only that these obfuscated sentences will not crash. + + map print(reverse), ('')x68; + print "ok 20\n"; + + map print(+()), ('')x68; + print "ok 21\n"; +} diff --git a/t/io/through.t b/t/io/through.t index d664b08a18..9c8a627f9d 100644 --- a/t/io/through.t +++ b/t/io/through.t @@ -34,7 +34,8 @@ $c += 6; # Tests with sleep()... print "1..$c\n"; my $set_out = ''; -$set_out = "binmode STDOUT, ':crlf'" if $main::use_crlf = 1; +$set_out = "binmode STDOUT, ':crlf'" + if defined $main::use_crlf && $main::use_crlf == 1; sub testread ($$$$$$$) { my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_; @@ -76,7 +77,8 @@ sub testpipe ($$$$$$) { } else { die "Unrecognized write: '$how_w'"; } - binmode $fh, ':crlf' if $main::use_crlf = 1; + binmode $fh, ':crlf' + if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why"); } @@ -86,7 +88,8 @@ sub testfile ($$$$$$) { open my $fh, '>', 'io_io.tmp' or die; select $fh; - binmode $fh, ':crlf' if $main::use_crlf = 1; + binmode $fh, ':crlf' + if defined $main::use_crlf && $main::use_crlf == 1; if ($how_w eq 'print') { # AUTOFLUSH??? $| = 0; print $fh $_ for @data; @@ -100,7 +103,8 @@ sub testfile ($$$$$$) { } close $fh or die "close: $!"; open $fh, '<', 'io_io.tmp' or die; - binmode $fh, ':crlf' if $main::use_crlf = 1; + binmode $fh, ':crlf' + if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); } @@ -109,7 +113,8 @@ open my $fh, '-|', qq[$Perl -we "eval qq(\\x24\\x7c = 1) or die; binmode STDOUT; ok(1, 'open pipe'); binmode $fh, q(:crlf); ok(1, 'binmode'); -my (@c, $c); +$c = undef; +my @c; push @c, ord $c while $c = getc $fh; ok(1, 'got chars'); is(scalar @c, 9, 'got 9 chars'); diff --git a/t/lib/1_compile.t b/t/lib/1_compile.t index 9c37830166..ee65b55810 100644 --- a/t/lib/1_compile.t +++ b/t/lib/1_compile.t @@ -40,6 +40,10 @@ if (@Core_Modules) { } else { print $message; } +print <<'EOREWARD'; +# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-04/msg01223.html +# 20010421230349.P2946@blackrider.blackstar.co.uk +EOREWARD my $test_num = 2; diff --git a/t/op/array.t b/t/op/array.t index 956a934290..64c0ad4969 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -61,7 +61,7 @@ is($r, "0,0"); $bar[2] = '2'; $r = join(',', $#bar, @bar); is($r, "2,0,,2"); -reset 'b'; +reset 'b' if $^O ne 'VMS'; @bar = (); $bar[0] = '0'; $r = join(',', $#bar, @bar); diff --git a/t/op/chop.t b/t/op/chop.t index a77ff30b6c..b0308b0902 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 137; +plan tests => 139; $_ = 'abc'; $c = do foo(); @@ -232,3 +232,14 @@ foreach my $start (@chars) { is($asc, "perl", "chopped ascii NUL"); is($utf, "perl", "chopped utf8 NUL"); } + +{ + # Change 26011: Re: A surprising segfault + # to make sure only that these obfuscated sentences will not crash. + + map chop(+()), ('')x68; + ok(1, "extend sp in pp_chop"); + + map chomp(+()), ('')x68; + ok(1, "extend sp in pp_chomp"); +} diff --git a/t/op/closure.t b/t/op/closure.t index de9e102a7f..340618046c 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -12,6 +12,7 @@ BEGIN { } use Config; +require './test.pl'; # for runperl() print "1..187\n"; @@ -446,8 +447,8 @@ END close READ2; open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; - exec './perl', '-w', '-' - or die "Can't exec ./perl: $!"; + exec which_perl(), '-w', '-' + or die "Can't exec perl: $!"; } else { # Parent process here. close WRITE; @@ -466,11 +467,7 @@ END my $errfile = "terr$$"; $errfile++ while -e $errfile; my @tmpfiles = ($cmdfile, $errfile); open CMD, ">$cmdfile"; print CMD $code; close CMD; - my $cmd = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : ($^O eq 'MacOS') ? $^X - : ($^O eq 'NetWare') ? 'perl' - : './perl'); + my $cmd = which_perl(); $cmd .= " -w $cmdfile 2>$errfile"; if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { # Use pipe instead of system so we don't inherit STD* from @@ -614,8 +611,6 @@ SKIP: { skip("tests not in 5.8.", 3) } $test= 185; -require './test.pl'; # for runperl() - { # bugid #23265 - this used to coredump during destruction of PL_maincv # and its children diff --git a/t/op/index.t b/t/op/index.t index d223265c4f..100439d15e 100755 --- a/t/op/index.t +++ b/t/op/index.t @@ -7,7 +7,7 @@ BEGIN { use strict; require './test.pl'; -plan( tests => 46 ); +plan( tests => 58 ); my $foo = 'Now is the time for all good men to come to the aid of their country.'; @@ -45,6 +45,20 @@ is(rindex("ababa","a",3), 2); is(rindex("ababa","a",4), 4); is(rindex("ababa","a",5), 4); +# tests for empty search string +is(index("abc", "", -1), 0); +is(index("abc", "", 0), 0); +is(index("abc", "", 1), 1); +is(index("abc", "", 2), 2); +is(index("abc", "", 3), 3); +is(index("abc", "", 4), 3); +is(rindex("abc", "", -1), 0); +is(rindex("abc", "", 0), 0); +is(rindex("abc", "", 1), 1); +is(rindex("abc", "", 2), 2); +is(rindex("abc", "", 3), 3); +is(rindex("abc", "", 4), 3); + $a = "foo \x{1234}bar"; is(index($a, "\x{1234}"), 4); diff --git a/t/op/list.t b/t/op/list.t index 89ccf02c10..cdf8cdd4e7 100755 --- a/t/op/list.t +++ b/t/op/list.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..31\n"; @foo = (1, 2, 3, 4); if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} @@ -95,4 +95,8 @@ for ($x = 0; $x < 3; $x++) { @b = (30, scalar @h{()}); print "not " if join(':',@b) ne '30:'; print "ok 30\n"; + + my $size = scalar(()[1..1]); + print "not " if $size != 0; + print "ok 31\n"; } diff --git a/t/op/magic.t b/t/op/magic.t index 54be238c7f..b28a082e79 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -49,10 +49,11 @@ $Is_MPE = $^O eq 'mpeix'; $Is_miniperl = $ENV{PERL_CORE_MINITEST}; $Is_BeOS = $^O eq 'beos'; -$PERL = ($Is_NetWare ? 'perl' : - ($Is_MacOS || $Is_VMS) ? $^X : - $Is_MSWin32 ? '.\perl' : - './perl'); +$PERL = $ENV{PERL} + || ($Is_NetWare ? 'perl' : + ($Is_MacOS || $Is_VMS) ? $^X : + $Is_MSWin32 ? '.\perl' : + './perl'); eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval # cmd.exe will echo 'variable=value' but 4nt will echo just the value diff --git a/t/op/pat.t b/t/op/pat.t index b4e3f5ee5c..5ba099fde3 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -81,12 +81,21 @@ $XXX{345} = 345; while ($_ = shift(@XXX)) { ?(.*)? && (print $1,"\n"); /not/ && reset; - /not ok 26/ && reset 'X'; + if (/not ok 26/) { + if ($^O eq 'VMS') { + $_ = shift(@XXX); + } + else { + reset 'X'; + } + } } -while (($key,$val) = each(%XXX)) { +if ($^O ne 'VMS') { + while (($key,$val) = each(%XXX)) { print "not ok 27\n"; exit; + } } print "ok 27\n"; diff --git a/t/op/sleep.t b/t/op/sleep.t index c2684ad37c..3f5bbe0d3f 100755 --- a/t/op/sleep.t +++ b/t/op/sleep.t @@ -1,8 +1,15 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + @INC = qw(. ../lib); +} + +require "test.pl"; +plan( tests => 4 ); + use strict; use warnings; -use Test::More tests=>4; my $start = time; my $sleep_says = sleep 3; diff --git a/t/op/sort.t b/t/op/sort.t index bdb48856b9..be011b64a9 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -14,6 +14,9 @@ print "1..129\n"; sort { while(1) {} } @a; sort { while(1) { last; } } @a; sort { while(0) { last; } } @a; + + # Change 26011: Re: A surprising segfault + map scalar(sort(+())), ('')x68; } sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 4130a5a89c..7e3e6c595b 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -12,28 +12,11 @@ BEGIN { } use warnings; use Config; +use strict; -# strictness my @tests = (); my ($i, $template, $data, $result, $comment, $w, $x, $evalData, $n, $p); -while (<DATA>) { - s/^\s*>//; s/<\s*$//; - push @tests, [split(/<\s*>/, $_, 4)]; -} - -print '1..', scalar @tests, "\n"; - -$SIG{__WARN__} = sub { - if ($_[0] =~ /^Invalid conversion/) { - $w = ' INVALID'; - } elsif ($_[0] =~ /^Use of uninitialized value/) { - $w = ' UNINIT'; - } else { - warn @_; - } -}; - my $Is_VMS_VAX = 0; # We use HW_MODEL since ARCH_NAME was not in VMS V5.* if ($^O eq 'VMS') { @@ -45,8 +28,9 @@ if ($^O eq 'VMS') { # No %Config. my $Is_Ultrix_VAX = $^O eq 'ultrix' && `uname -m` =~ /^VAX$/; -for ($i = 1; @tests; $i++) { - ($template, $data, $result, $comment) = @{shift @tests}; +while (<DATA>) { + s/^\s*>//; s/<\s*$//; + ($template, $data, $result, $comment) = split(/<\s*>/, $_, 4); if ($^O eq 'os390' || $^O eq 's390') { # non-IEEE (s390 is UTS) $data =~ s/([eE])96$/${1}63/; # smaller exponents $result =~ s/([eE]\+)102$/${1}69/; # " " @@ -62,10 +46,28 @@ for ($i = 1; @tests; $i++) { $data =~ s/([eE])\-101$/${1}-24/; # larger exponents $result =~ s/([eE])\-102$/${1}-25/; # " " } + $evalData = eval $data; + $data = ref $evalData ? $evalData : [$evalData]; + push @tests, [$template, $data, $result, $comment]; +} + +print '1..', scalar @tests, "\n"; + +$SIG{__WARN__} = sub { + if ($_[0] =~ /^Invalid conversion/) { + $w = ' INVALID'; + } elsif ($_[0] =~ /^Use of uninitialized value/) { + $w = ' UNINIT'; + } else { + warn @_; + } +}; + +for ($i = 1; @tests; $i++) { + ($template, $data, $result, $comment) = @{shift @tests}; $w = undef; - $x = sprintf(">$template<", - defined @$evalData ? @$evalData : $evalData); + $x = sprintf(">$template<", @$data); substr($x, -1, 0) = $w if $w; # $x may have 3 exponent digits, not 2 my $y = $x; diff --git a/t/op/threads.t b/t/op/threads.t new file mode 100644 index 0000000000..7fecba13a6 --- /dev/null +++ b/t/op/threads.t @@ -0,0 +1,98 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; # for which_perl() etc + $| = 1; +} + +use strict; +use Config; + +BEGIN { + if (!$Config{useithreads}) { + print "1..0 # Skip: no ithreads\n"; + exit 0; + } + if ($ENV{PERL_CORE_MINITEST}) { + print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; + exit 0; + } + plan(4); +} +use threads; + +# test that we don't get: +# Attempt to free unreferenced scalar: SV 0x40173f3c +fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads'); +use threads; +threads->new(sub { my %h=(1,2); delete $h{1}})->join for 1..2; +print "ok"; +EOI + +#PR24660 +# test that we don't get: +# Attempt to free unreferenced scalar: SV 0x814e0dc. +fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads'); +use threads; +use Scalar::Util; +my $data = "a"; +my $obj = \$data; +my $copy = $obj; +Scalar::Util::weaken($copy); +threads->new(sub { 1 })->join for (1..1); +print "ok"; +EOI + +#PR24663 +# test that we don't get: +# panic: magic_killbackrefs. +# Scalars leaked: 3 +fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads'); +package Foo; +sub new { bless {},shift } +package main; +use threads; +use Scalar::Util qw(weaken); +my $object = Foo->new; +my $ref = $object; +weaken $ref; +threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems +print "ok"; +EOI + +#PR30333 - sort() crash with threads +sub mycmp { length($b) <=> length($a) } + +sub do_sort_one_thread { + my $kid = shift; + print "# kid $kid before sort\n"; + my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', + 'hello', 's', 'thisisalongname', '1', '2', '3', + 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); + + for my $j (1..99999) { + for my $k (sort mycmp @list) {} + } + print "# kid $kid after sort, sleeping 1\n"; + sleep(1); + print "# kid $kid exit\n"; +} + +sub do_sort_threads { + my $nthreads = shift; + my @kids = (); + for my $i (1..$nthreads) { + my $t = threads->new(\&do_sort_one_thread, $i); + print "# parent $$: continue\n"; + push(@kids, $t); + } + for my $t (@kids) { + print "# parent $$: waiting for join\n"; + $t->join(); + print "# parent $$: thread exited\n"; + } +} + +do_sort_threads(2); # crashes +ok(1); diff --git a/t/run/runenv.t b/t/run/runenv.t index df4a778b4d..bbe231f9b4 100644 --- a/t/run/runenv.t +++ b/t/run/runenv.t @@ -20,7 +20,7 @@ plan tests => 17; my $STDOUT = './results-0'; my $STDERR = './results-1'; -my $PERL = './perl'; +my $PERL = $ENV{PERL} || './perl'; my $FAILURE_CODE = 119; delete $ENV{PERLLIB}; @@ -258,6 +258,7 @@ sub like_yn ($$$@) { unshift(@mess, "# got '$got'\n", "# expected /$expected/\n"); } + local $Level = 2; _ok($pass, _where(), $name, @mess); } @@ -296,7 +297,7 @@ sub todo_skip { my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "ok $test # TODO & SKIP: $why\n"; + print STDOUT "not ok $test # TODO & SKIP: $why\n"; $test++; } local $^W = 0; |