diff options
| author | Jarkko Hietaniemi <jhi@iki.fi> | 2000-01-13 16:31:34 +0000 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2000-01-13 16:31:34 +0000 |
| commit | 434d2535978fdc93cf6e9722bc7f9d272a9c2632 (patch) | |
| tree | dd1640d56ae63acd3cdc1ed34863bc656a13dbc3 /t | |
| parent | d132b95fb004c5e3d94e297d3804c90cfef96fed (diff) | |
| parent | 8ea97a1e700347a7b6ed9267c8c34f286f94d5d6 (diff) | |
| download | perl-434d2535978fdc93cf6e9722bc7f9d272a9c2632.tar.gz | |
Integrate with Sarathy.
p4raw-id: //depot/cfgperl@4798
Diffstat (limited to 't')
50 files changed, 1471 insertions, 400 deletions
@@ -153,7 +153,7 @@ EOT } } else { - $pct = sprintf("%.2f", ($files - $bad) / $files * 100); + $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00"; if ($bad == 1) { warn "Failed 1 test script out of $files, $pct% okay.\n"; } diff --git a/t/comp/require.t b/t/comp/require.t index 581dcba75c..d4c9d8ca61 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -7,7 +7,7 @@ BEGIN { # don't make this lexical $i = 1; -print "1..4\n"; +print "1..16\n"; sub do_require { %INC = (); @@ -23,6 +23,56 @@ sub write_file { close REQ; } +# new style version numbers + +eval { require v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +eval q{ use v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval q{ use v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +my $ver = v5.5.630; +eval { require $ver; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +$ver = v10.0.2; +eval { require $ver; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +print "not " unless v5.5.1 gt v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_01 > v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_64 - v5.5.640 < 0.0000001; +print "ok ",$i++,"\n"; + +{ + use utf8; + print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; + print "ok ",$i++,"\n"; + + print "not " unless v7.15 eq "\x{7}\x{f}"; + print "ok ",$i++,"\n"; + + print "not " + unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; + 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/term.t b/t/comp/term.t index eb9968003e..f079eef58b 100755 --- a/t/comp/term.t +++ b/t/comp/term.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $ - # tests that aren't important enough for base.term -print "1..22\n"; +print "1..23\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; @@ -68,3 +66,7 @@ if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} $a = "+{ \$a=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} + +$a = "{ 0x01 => 'foo'}->{0x01}"; +$a = eval $a; +if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} diff --git a/t/io/argv.t b/t/io/argv.t index c6565dc9c7..d6093f90ef 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -1,24 +1,33 @@ #!./perl -print "1..6\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..20\n"; + +use File::Spec; + +my $devnull = File::Spec->devnull; -open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); +open(try, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; if ($^O eq 'MSWin32') { - $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; + $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`; } else { - $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; + $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`; } if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`; + $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`; } else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; + $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`; } if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} @@ -30,7 +39,7 @@ else { } if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} -@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); +@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); while (<>) { $y .= $. . $_; if (eof()) { @@ -43,17 +52,74 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '>Io_argv1.tmp') or die "Can't open temp file: $!"; close try; -@ARGV = 'Io.argv.tmp'; +open(try, '>Io_argv2.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '.bak'; $/ = undef; +my $i = 6; while (<>) { - s/^/ok 6\n/; + s/^/ok $i\n/; + ++$i; print; } -open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '<Io_argv1.tmp') or die "Can't open temp file: $!"; +print while <try>; +open(try, '<Io_argv2.tmp') or die "Can't open temp file: $!"; print while <try>; close try; +undef $^I; + +eof try or print 'not '; +print "ok 8\n"; + +eof NEVEROPENED or print 'not '; +print "ok 9\n"; + +open STDIN, 'Io_argv1.tmp' or die $!; +@ARGV = (); +!eof() or print 'not '; +print "ok 10\n"; + +<> eq "ok 6\n" or print 'not '; +print "ok 11\n"; + +open STDIN, $devnull or die $!; +@ARGV = (); +eof() or print 'not '; +print "ok 12\n"; + +@ARGV = ('Io_argv1.tmp'); +!eof() or print 'not '; +print "ok 13\n"; + +@ARGV = ($devnull, $devnull); +!eof() or print 'not '; +print "ok 14\n"; + +close ARGV or die $!; +eof() or print 'not '; +print "ok 15\n"; + +{ + local $/; + open F, 'Io_argv1.tmp' or die; + <F>; # set $. = 1 + open F, $devnull or die; + print "not " unless defined(<F>); + print "ok 16\n"; + print "not " if defined(<F>); + print "ok 17\n"; + print "not " if defined(<F>); + print "ok 18\n"; + open F, $devnull or die; # restart cycle again + print "not " unless defined(<F>); + print "ok 19\n"; + print "not " if defined(<F>); + print "ok 20\n"; + close F; +} -END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } +END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp.bak', 'Io_argv2.tmp', 'Io_argv2.tmp.bak' } diff --git a/t/io/nargv.t b/t/io/nargv.t index f32e40d6ee..fb13857618 100755 --- a/t/io/nargv.t +++ b/t/io/nargv.t @@ -56,7 +56,7 @@ sub other { } sub mkfiles { - my @files = map { "scratch.$_" } @_; + my @files = map { "scratch$_" } @_; return wantarray ? @files : $files[-1]; } diff --git a/t/io/open.t b/t/io/open.t index 905aee50af..1e9409171c 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -5,110 +5,273 @@ $| = 1; $^W = 1; $Is_VMS = $^O eq 'VMS'; -print "1..32\n"; +print "1..66\n"; + +my $test = 1; + +sub ok { print "ok $test\n"; $test++ } # my $file tests +# 1..9 { -unlink("afile") if -f "afile"; -print "$!\nnot " unless open(my $f,"+>afile"); -print "ok 1\n"; -binmode $f; -print "not " unless -f "afile"; -print "ok 2\n"; -print "not " unless print $f "SomeData\n"; -print "ok 3\n"; -print "not " unless tell($f) == 9; -print "ok 4\n"; -print "not " unless seek($f,0,0); -print "ok 5\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 6\n"; -print "not " unless -f $f; -print "ok 7\n"; -eval { die "Message" }; -# warn $@; -print "not " unless $@ =~ /<\$f> line 1/; -print "ok 8\n"; -print "not " unless close($f); -print "ok 9\n"; -unlink("afile"); + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(my $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); } + +# 10..12 { -print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); -print "ok 10\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 11\n"; -print "not " unless -s 'afile' < 10; -print "ok 12\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; } + +# 13..15 { -print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); -print "ok 13\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 14\n"; -print "not " unless -s 'afile' > 10; -print "ok 15\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; } + +# 16..18 { -print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); -print "ok 16\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 17\n"; -print "not " unless close($f); -print "ok 18\n"; + print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; } + +# 19..23 { -print "not " unless -s 'afile' < 20; -print "ok 19\n"; -print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); -print "ok 20\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 21\n"; -seek $f, 0, 1; -print $f "yet another row\n"; -print "not " unless close($f); -print "ok 22\n"; -print "not " unless -s 'afile' > 20; -print "ok 23\n"; - -unlink("afile"); -} -if ($Is_VMS) { for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } } + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 24..26 +if ($Is_VMS) { + for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); -./perl -e "print qq(a row\n); print qq(another row\n)" + print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" EOC -print "ok 24\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 25\n"; -print "not " unless close($f); -print "ok 26\n"; -} -if ($Is_VMS) { for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } } + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 27..30 +if ($Is_VMS) { + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); -./perl -pe "s/^not //" + print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" EOC -print "ok 27\n"; -@rows = <$f>; -print $f "not ok 28\n"; -print $f "not ok 29\n"; -print "#\nnot " unless close($f); -sleep 1; -print "ok 30\n"; + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; } +# 31..32 eval <<'EOE' and print "not "; open my $f, '<&', 'afile'; 1; EOE -print "ok 31\n"; +ok; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +ok; + +# local $file tests + +# 33..41 +{ + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(local $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); +} + +# 42..44 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; +} + +# 45..47 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; +} + +# 48..50 +{ + print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 51..55 +{ + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 56..58 +if ($Is_VMS) { + for (56..58) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" +EOC + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 59..62 +if ($Is_VMS) { + for (59..62) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" +EOC + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; +} + +# 63..64 +eval <<'EOE' and print "not "; +open local $f, '<&', 'afile'; +1; +EOE +ok; $@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; -print "ok 32\n"; +ok; + +# 65..66 +{ + local *F; + for (1..2) { + open(F, "echo #foo|") or print "not "; + print <F>; + close F; + } + ok; + for (1..2) { + open(F, "-|", "echo #foo") or print "not "; + print <F>; + close F; + } + ok; +} diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t index 42cd9583d1..4cfd36e02d 100755 --- a/t/lib/bigfltpm.t +++ b/t/lib/bigfltpm.t @@ -9,7 +9,7 @@ use Math::BigFloat; $test = 0; $| = 1; -print "1..358\n"; +print "1..362\n"; while (<DATA>) { chop; if (s/^&//) { @@ -41,15 +41,15 @@ while (<DATA>) { $try .= "0+\$x->fsqrt;"; } else { $try .= "\$y = new Math::BigFloat \"$args[1]\";"; - if ($f eq fcmp){ + if ($f eq "fcmp") { $try .= "\$x <=> \$y;"; - }elsif ($f eq fadd){ + } elsif ($f eq "fadd") { $try .= "\$x + \$y;"; - }elsif ($f eq fsub){ + } elsif ($f eq "fsub") { $try .= "\$x - \$y;"; - }elsif ($f eq fmul){ + } elsif ($f eq "fmul") { $try .= "\$x * \$y;"; - }elsif ($f eq fdiv){ + } elsif ($f eq "fdiv") { $try .= "\$x / \$y;"; } else { warn "Unknown op"; } } @@ -271,6 +271,10 @@ abc:+0: +1:-1:1 -1:-1:0 +1:+1:0 +-1.1:0:-1 ++0:-1.1:1 ++1.1:+0:1 ++0:+1.1:-1 +123:+123:0 +123:+12:1 +12:+123:-1 diff --git a/t/lib/charnames.t b/t/lib/charnames.t index b03083e6d1..9775b141b2 100644 --- a/t/lib/charnames.t +++ b/t/lib/charnames.t @@ -12,7 +12,7 @@ print "1..5\n"; use charnames ':full'; -print "not " unless "Here\N{EXCLAMATION MARK}?" eq 'Here!?'; +print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; print "ok 1\n"; { diff --git a/t/lib/dumper.t b/t/lib/dumper.t index 9130d1c690..0ac269620d 100755 --- a/t/lib/dumper.t +++ b/t/lib/dumper.t @@ -9,6 +9,8 @@ BEGIN { } use Data::Dumper; +use Config; +my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; $Data::Dumper::Pad = "#"; my $TMAX; @@ -22,6 +24,14 @@ sub TEST { ++$TNUM; $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # these data need massaging with non ascii character sets + # because of hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); @@ -33,6 +43,13 @@ sub TEST { ++$TNUM; $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # here too there are hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); } diff --git a/t/lib/english.t b/t/lib/english.t index 2ee613352b..dba68dbf94 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -5,7 +5,7 @@ print "1..16\n"; BEGIN { unshift @INC, '../lib' } use English; use Config; -my $threads = $Config{'usethreads'} || 0; +my $threads = $Config{'use5005threads'} || 0; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 7ef68eb02b..b6fcbeafa6 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -5,88 +5,103 @@ BEGIN { unshift @INC, '../lib'; } -print "1..11\n"; - $| = 1; +my @pass = (0,1); +my $tests = 11; +printf "1..%d\n", $tests * scalar(@pass); + use File::Copy; -# First we create a file -open(F, ">file-$$") or die; -binmode F; # for DOSISH platforms, because test 3 copies to stdout -print F "ok 3\n"; -close F; - -copy "file-$$", "copy-$$"; - -open(F, "copy-$$") or die; -$foo = <F>; -close(F); - -print "not " if -s "file-$$" != -s "copy-$$"; -print "ok 1\n"; - -print "not " unless $foo eq "ok 3\n"; -print "ok 2\n"; - -binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode -copy "copy-$$", \*STDOUT; -unlink "copy-$$" or die "unlink: $!"; - -open(F,"file-$$"); -copy(*F, "copy-$$"); -open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 4\n"; -unlink "copy-$$" or die "unlink: $!"; -open(F,"file-$$"); -copy(\*F, "copy-$$"); -close(F) or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; -print "not " unless $foo eq "ok 3\n"; -print "ok 5\n"; -unlink "copy-$$" or die "unlink: $!"; - -require IO::File; -$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 6\n"; -unlink "copy-$$" or die "unlink: $!"; -require FileHandle; -my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 7\n"; -unlink "file-$$" or die "unlink: $!"; - -print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); -print "# target disappeared.\nnot " if not -e "copy-$$"; -print "ok 8\n"; - -move "copy-$$", "file-$$" or print "# move did not succeed.\n"; -print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; -open(R, "file-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 9\n"; - -copy "file-$$", "lib"; -open(R, "lib/file-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 10\n"; -unlink "lib/file-$$" or die "unlink: $!"; - -move "file-$$", "lib"; -open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; -print "ok 11\n"; -unlink "lib/file-$$" or die "unlink: $!"; +for my $pass (@pass) { + + require File::Copy; + + my $loopconst = $pass*$tests; + + # First we create a file + open(F, ">file-$$") or die; + binmode F; # for DOSISH platforms, because test 3 copies to stdout + printf F "ok %d\n", 3 + $loopconst; + close F; + + copy "file-$$", "copy-$$"; + + open(F, "copy-$$") or die; + $foo = <F>; + close(F); + + print "not " if -s "file-$$" != -s "copy-$$"; + printf "ok %d\n", 1 + $loopconst; + + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 2+$loopconst; + + binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode + copy "copy-$$", \*STDOUT; + unlink "copy-$$" or die "unlink: $!"; + + open(F,"file-$$"); + copy(*F, "copy-$$"); + open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 4+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + open(F,"file-$$"); + copy(\*F, "copy-$$"); + close(F) or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 5+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + + require IO::File; + $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 6+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + require FileHandle; + my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 7+$loopconst; + unlink "file-$$" or die "unlink: $!"; + + print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); + print "# target disappeared.\nnot " if not -e "copy-$$"; + printf "ok %d\n", 8+$loopconst; + + move "copy-$$", "file-$$" or print "# move did not succeed.\n"; + print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; + open(R, "file-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 9+$loopconst; + + copy "file-$$", "lib"; + open(R, "lib/file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + move "file-$$", "lib"; + open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 11+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + # warn sprintf "INC->".$INC{"File/Copy.pm"}; + delete $INC{"File/Copy.pm"}; + +} + END { 1 while unlink "file-$$"; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 5d1492f040..f958b19cad 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -1,14 +1,105 @@ -#!./perl +####!./perl + + +my %Expect; +my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..2\n"; +if ( $symlink_exists ) { print "1..59\n"; } +else { print "1..31\n"; } use File::Find; -# hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); + + +my $case = 2; + +END { + unlink 'FA/FA_ord','FA/FSL','FA/FAA/FAA_ord', + 'FA/FAB/FAB_ord','FA/FAB/FABA/FABA_ord','FB/FB_ord','FB/FBA/FBA_ord'; + rmdir 'FA/FAA'; + rmdir 'FA/FAB/FABA'; + rmdir 'FA/FAB'; + rmdir 'FA'; + rmdir 'FB/FBA'; + rmdir 'FB'; +} + +sub Check($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n"; } +} + +sub CheckDie($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { + CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { + CheckDie( mkdir($_[0],$_[1]) ); +} + +sub wanted { + print "# '$_' => 1\n"; + Check( $Expect{$_} ); + delete $Expect{$_}; + $File::Find::prune=1 if $_ eq 'FABA'; +} + +MkDir( 'FA',0770 ); +MkDir( 'FB',0770 ); +touch('FB/FB_ord'); +MkDir( 'FB/FBA',0770 ); +touch('FB/FBA/FBA_ord'); +CheckDie( symlink('../FB','FA/FSL') ) if $symlink_exists; +touch('FA/FA_ord'); + +MkDir( 'FA/FAA',0770 ); +touch('FA/FAA/FAA_ord'); +MkDir( 'FA/FAB',0770 ); +touch('FA/FAB/FAB_ord'); +MkDir( 'FA/FAB/FABA',0770 ); +touch('FA/FAB/FABA/FABA_ord'); + +%Expect = ('.' => 1, 'FSL' => 1, 'FA_ord' => 1, 'FAB' => 1, 'FAB_ord' => 1, + 'FABA' => 1, 'FAA' => 1, 'FAA_ord' => 1); +delete $Expect{'FSL'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, },'FA' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('FA' => 1, 'FA/FSL' => 1, 'FA/FA_ord' => 1, 'FA/FAB' => 1, + 'FA/FAB/FAB_ord' => 1, 'FA/FAB/FABA' => 1, + 'FA/FAB/FABA/FABA_ord' => 1, 'FA/FAA' => 1, 'FA/FAA/FAA_ord' => 1); +delete $Expect{'FA/FSL'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, no_chdir => 1},'FA' ); + +Check( scalar(keys %Expect) == 0 ); + +if ( $symlink_exists ) { + %Expect=('.' => 1, 'FA_ord' => 1, 'FSL' => 1, 'FB_ord' => 1, 'FBA' => 1, + 'FBA_ord' => 1, 'FAB' => 1, 'FAB_ord' => 1, 'FABA' => 1, 'FAA' => 1, + 'FAA_ord' => 1); + + File::Find::find( {wanted => \&wanted, follow_fast => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); + %Expect=('FA' => 1, 'FA/FA_ord' => 1, 'FA/FSL' => 1, 'FA/FSL/FB_ord' => 1, + 'FA/FSL/FBA' => 1, 'FA/FSL/FBA/FBA_ord' => 1, 'FA/FAB' => 1, + 'FA/FAB/FAB_ord' => 1, 'FA/FAB/FABA' => 1, 'FA/FAB/FABA/FABA_ord' => 1, + 'FA/FAA' => 1, 'FA/FAA/FAA_ord' => 1); + File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); +} + +print "# of cases: $case\n"; diff --git a/t/lib/glob-case.t b/t/lib/glob-case.t new file mode 100755 index 0000000000..2e65a0fc8b --- /dev/null +++ b/t/lib/glob-case.t @@ -0,0 +1,48 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob("lib/G*.t"); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... +if ($^O ne 'MSWin32') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --git a/t/lib/glob-global.t b/t/lib/glob-global.t index 7da741ee16..44d7e8b5c3 100755 --- a/t/lib/glob-global.t +++ b/t/lib/glob-global.t @@ -23,7 +23,7 @@ EOMessage } } -use File::Glob 'globally'; +use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; @@ -81,7 +81,7 @@ print "ok 8\n"; # how about in a different package, like? package Foo; -use File::Glob 'globally'; +use File::Glob ':globally'; @s = (); while (glob '*/*.t') { #print "# $_\n"; diff --git a/t/lib/safe2.t b/t/lib/safe2.t index 2c1c80c604..876e7a37db 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -66,7 +66,7 @@ $glob = "ok 11\n"; sub sayok { print "ok @_\n" } $cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{archname} =~ /-thread$/; +$cpt->share('$"') unless $Config{use5005threads}; $cpt->reval(q{ package other; diff --git a/t/lib/thread.t b/t/lib/thread.t index 6c25407853..edfb443fc8 100755 --- a/t/lib/thread.t +++ b/t/lib/thread.t @@ -4,8 +4,8 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; - if (! $Config{'usethreads'}) { - print "1..0 # Skip: this perl is not threaded\n"; + if (! $Config{'use5005threads'}) { + print "1..0 # Skip: not use5005threads\n"; exit 0; } @@ -13,8 +13,8 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..18\n"; -use Thread; +print "1..21\n"; +use Thread 'yield'; print "ok 1\n"; sub content @@ -82,3 +82,37 @@ Loch::Ness->monster(15); Loch::Ness->new->monster(16); Loch::Ness->gollum(17); Loch::Ness->new->gollum(18); + +my $short = "This is a long string that goes on and on."; +my $shorte = " a long string that goes on and on."; +my $long = "This is short."; +my $longe = " short."; +my $thr1 = new Thread \&threaded, $short, $shorte, "19"; +my $thr2 = new Thread \&threaded, $long, $longe, "20"; + +sub threaded { + my ($string, $string_end, $testno) = @_; + + # Do the match, saving the output in appropriate variables + $string =~ /(.*)(is)(.*)/; + # Yield control, allowing the other thread to fill in the match variables + yield(); + # Examine the match variable contents; on broken perls this fails + if ($3 eq $string_end) { + print "ok $testno\n"; + } + else { + warn <<EOT; + +# +# This is a KNOWN FAILURE, and one of the reasons why threading +# is still an experimental feature. It is here to stop people +# from deploying threads in production. ;-) +# +EOT + print "not ok $testno # other thread filled in match variables\n"; + } +} +$thr1->join; +$thr2->join; +print "ok 21\n"; diff --git a/t/op/avhv.t b/t/op/avhv.t index 92afa37d37..23f9c69c8c 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..15\n"; +print "1..20\n"; $sch = { 'abc' => 1, @@ -118,3 +118,24 @@ print "not " unless exists $avhv->{pants}; print "ok 14\n"; print "not " if exists $avhv->{bar}; print "ok 15\n"; + +$avhv->{bar} = 10; +print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; +print "ok 16\n"; + +$v = delete $avhv->{bar}; +print "not " unless $v == 10; +print "ok 17\n"; + +print "not " if exists $avhv->{bar}; +print "ok 18\n"; + +$avhv->{foo} = 'xxx'; +$avhv->{bar} = 'yyy'; +$avhv->{pants} = 'zzz'; +@x = delete @{$avhv}{'foo','pants'}; +print "# @x\nnot " unless "@x" eq "xxx zzz"; +print "ok 19\n"; + +print "not " unless "$avhv->{bar}" eq "yyy"; +print "ok 20\n"; diff --git a/t/op/delete.t b/t/op/delete.t index 6cc447506a..10a218b1b6 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ +print "1..36\n"; -print "1..16\n"; +# delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; @@ -13,7 +13,7 @@ $foo{5} = 'e'; $foo = delete $foo{2}; if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} +unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} @@ -24,8 +24,8 @@ if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} @@ -49,3 +49,75 @@ delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; + +{ + my %a = ('bar', 33); + my($a) = \(values %a); + my $b = \$a{bar}; + my $c = \delete $a{bar}; + + print "not " unless $a == $b && $b == $c; + print "ok 17\n"; +} + +# delete() on array elements + +@foo = (); +$foo[1] = 'a'; +$foo[2] = 'b'; +$foo[3] = 'c'; +$foo[4] = 'd'; +$foo[5] = 'e'; + +$foo = delete $foo[2]; + +if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} +unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} +if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} +if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} +if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} +if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} + +@bar = delete @foo[4,5]; + +if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} +if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} +if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} +unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} +unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} +if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} +if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} + +$foo = join('',@foo); +if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} + +if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} + +foreach $key (0 .. $#foo) { + delete $foo[$key]; +} + +if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} + +$foo[0] = 'x'; +$foo[1] = 'y'; + +$foo = "@foo"; +print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; + +$refary[0]->[0] = "FOO"; +$refary[0]->[3] = "BAR"; + +delete $refary[0]->[3]; + +print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; + +{ + my @a = 33; + my($a) = \(@a); + my $b = \$a[0]; + my $c = \delete $a[bar]; + + print "not " unless $a == $b && $b == $c; + print "ok 36\n"; +} diff --git a/t/op/fork.t b/t/op/fork.t index 20c87472b2..b743a4589f 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -1,26 +1,319 @@ #!./perl -# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +# tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { + unless ($Config{'d_fork'} || ($^O eq 'MSWin32' && $Config{'useithreads'})) { print "1..0 # Skip: no fork\n"; exit 0; } + $ENV{PERL5LIB} = "../lib"; } -$| = 1; -print "1..2\n"; +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "forktmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); +for (@prgs){ + my $switch; + if (s/^\s*(-\w.*)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + $expected =~ s/\n+$//; + # results can be in any order, so sort 'em + my @expected = sort split /\n/, $expected; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + my $results; + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } + $status = $?; + $results =~ s/\n+$//; + $results =~ s/at\s+forktmp\d+\s+line/at - line/g; + $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + my @results = sort split /\n/, $results; + if ( "@results" ne "@expected" ) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ +$| = 1; if ($cid = fork) { - sleep 2; - if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} + sleep 1; + if ($result = (kill 9, $cid)) { + print "ok 2\n"; + } + else { + print "not ok 2 $result\n"; + } + sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { - $| = 1; print "ok 1\n"; sleep 10; } +EXPECT +ok 1 +ok 2 +######## +$| = 1; +sub forkit { + print "iteration $i start\n"; + my $x = fork; + if (defined $x) { + if ($x) { + print "iteration $i parent\n"; + } + else { + print "iteration $i child\n"; + } + } + else { + print "pid $$ failed to fork\n"; + } +} +while ($i++ < 3) { do { forkit(); }; } +EXPECT +iteration 1 start +iteration 1 parent +iteration 1 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +######## +$| = 1; +fork() + ? (print("parent\n"),sleep(1)) + : (print("child\n"),exit) ; +EXPECT +parent +child +######## +$| = 1; +fork() + ? (print("parent\n"),exit) + : (print("child\n"),sleep(1)) ; +EXPECT +parent +child +######## +$| = 1; +@a = (1..3); +for (@a) { + if (fork) { + print "parent $_\n"; + $_ = "[$_]"; + } + else { + print "child $_\n"; + $_ = "-$_-"; + } +} +print "@a\n"; +EXPECT +parent 1 +child 1 +parent 2 +child 2 +parent 2 +child 2 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +[1] [2] [3] +-1- [2] [3] +[1] -2- [3] +[1] [2] -3- +-1- -2- [3] +-1- [2] -3- +[1] -2- -3- +-1- -2- -3- +######## +use Config; +$| = 1; +$\ = "\n"; +fork() + ? print($Config{osname} eq $^O) + : print($Config{osname} eq $^O) ; +EXPECT +1 +1 +######## +$| = 1; +$\ = "\n"; +fork() + ? do { require Config; print($Config::Config{osname} eq $^O); } + : do { require Config; print($Config::Config{osname} eq $^O); } +EXPECT +1 +1 +######## +$| = 1; +use Cwd; +$\ = "\n"; +my $dir; +if (fork) { + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; + chdir ".."; + rmdir $dir; +} +else { + sleep 2; + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; + chdir ".."; + rmdir $dir; +} +EXPECT +ok 1 parent +ok 1 child +######## +$| = 1; +$\ = "\n"; +my $getenv; +if ($^O eq 'MSWin32') { + $getenv = qq[$^X -e "print \$ENV{TST}"]; +} +else { + $getenv = qq[$^X -e 'print \$ENV{TST}']; +} +$ENV{TST} = 'foo'; +if (fork) { + sleep 1; + print "parent before: " . `$getenv`; + $ENV{TST} = 'bar'; + print "parent after: " . `$getenv`; +} +else { + print "child before: " . `$getenv`; + $ENV{TST} = 'baz'; + print "child after: " . `$getenv`; +} +EXPECT +child before: foo +child after: baz +parent before: foo +parent after: bar +######## +$| = 1; +$\ = "\n"; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exit(42); +} +EXPECT +parent got 10752 +######## +$| = 1; +$\ = "\n"; +my $echo = 'echo'; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exec("$echo foo"); +} +EXPECT +foo +parent got 0 +######## +if (fork) { + die "parent died"; +} +else { + die "child died"; +} +EXPECT +parent died at - line 2. +child died at - line 5. +######## +if ($pid = fork) { + eval { die "parent died" }; + print $@; +} +else { + eval { die "child died" }; + print $@; +} +EXPECT +parent died at - line 2. +child died at - line 6. +######## +if (eval q{$pid = fork}) { + eval q{ die "parent died" }; + print $@; +} +else { + eval q{ die "child died" }; + print $@; +} +EXPECT +parent died at (eval 2) line 1. +child died at (eval 2) line 1. +######## +BEGIN { + $| = 1; + fork and exit; + print "inner\n"; +} +# XXX In emulated fork(), the child will not execute anything after +# the BEGIN block, due to difficulties in recreating the parse stacks +# and restarting yyparse() midstream in the child. This can potentially +# be overcome by treating what's after the BEGIN{} as a brand new parse. +#print "outer\n" +EXPECT +inner diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t index 0f658694dd..56ddfff866 100755 --- a/t/op/lex_assign.t +++ b/t/op/lex_assign.t @@ -24,7 +24,7 @@ sub subb {"in s"} @INPUT = <DATA>; @simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; -print "1..", (8 + @INPUT + @simple_input), "\n"; +print "1..", (9 + @INPUT + @simple_input), "\n"; $ord = 0; sub wrn {"@_"} @@ -53,6 +53,12 @@ $ord++; print "not " unless $dc == 1; print "ok $ord\n"; +$ord++; +my $xxx = 'b'; +$xxx = 'c' . ($xxx || 'e'); +print "not " unless $xxx eq 'cb'; +print "ok $ord\n"; + { # Check calling STORE my $sc = 0; sub B::TIESCALAR {bless [11], 'B'} diff --git a/t/op/magic.t b/t/op/magic.t index fe55521814..0d5190a2bb 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -23,7 +23,7 @@ $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; $Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O =~ /cygwin/; +$Is_Cygwin = $^O eq 'cygwin'; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); print "1..35\n"; diff --git a/t/op/misc.t b/t/op/misc.t index ab849777da..9f8c7dedab 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -506,4 +506,4 @@ else { if ($x == 0) { print "" } else { print $x } } EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in numeric eq (==) at - line 4. diff --git a/t/op/nothread.t b/t/op/nothread.t index a434956cb0..fd36e2e89a 100755 --- a/t/op/nothread.t +++ b/t/op/nothread.t @@ -9,7 +9,7 @@ BEGIN unshift @INC, "../lib"; require Config; import Config; - if ($Config{'usethreads'}) + if ($Config{'use5005threads'}) { print "1..0 # Skip: this perl is threaded\n"; exit 0; diff --git a/t/op/pat.t b/t/op/pat.t index 5c564aa719..9f685502f2 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,7 +4,7 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..194\n"; +print "1..195\n"; BEGIN { chdir 't' if -d 't'; @@ -898,3 +898,10 @@ $text = "xA\n" x 500; $text =~ /^\s*A/m and print 'not '; print "ok $test\n"; $test++; + +$text = "abc dbf"; +@res = ($text =~ /.*?(b).*?\b/g); +"@res" eq 'b b' or print 'not '; +print "ok $test\n"; +$test++; + diff --git a/t/op/range.t b/t/op/range.t index 1698db4a55..e8aecf5fc9 100755 --- a/t/op/range.t +++ b/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..13\n"; +print "1..15\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -64,3 +64,12 @@ print "ok 12\n"; $bad = 1 unless $x eq 'a:b:c:d:e'; print $bad ? "not ok 13\n" : "ok 13\n"; } + +# Should use magical autoinc only when both are strings +print "not " unless 0 == (() = "0"..-1); +print "ok 14\n"; + +for my $x ("0"..-1) { + print "not "; +} +print "ok 15\n"; diff --git a/t/op/re_tests b/t/op/re_tests index f866385096..d506e6e07f 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -744,3 +744,9 @@ tt+$ xxxtt y - - \GX.*X aaaXbX n - - (\d+\.\d+) 3.1415926 y $1 3.1415926 (\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c +^([a-z]:) C:/ n - - +'^\S\s+aa$'m \nx aa y - - +(^|a)b ab y - - diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 1dc2a234b2..1d923cf1b5 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -3,7 +3,7 @@ ## ## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> ## chdir 't' if -d 't'; @@ -57,7 +57,7 @@ __END__ @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -174,7 +174,7 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. ######## sub sortfn { (split(/./, 'x'x10000))[0]; @@ -227,7 +227,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -Can't "next" outside a block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -285,7 +285,7 @@ package main; tie $bar, TEST; } EXPECT -Can't "next" outside a block at - line 4. +Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: diff --git a/t/op/sort.t b/t/op/sort.t index 9abc4105d2..6e3d2ca8e0 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -4,12 +4,13 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..38\n"; +print "1..49\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; $^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); *twoface = sub { *twoface = *backwards; $a <=> $b }; eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; my @result = sort main'backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { my $sortsub = \&backwards; @@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $sortglobr = \*backwards; my $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); +} + +{ + my $sortsub = \&backwards_stacked; + my $sortglob = *backwards_stacked; + my $sortglobr = \*backwards_stacked; + my $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); } { @@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; local $sortglobr = \*backwards; local $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&backwards_stacked; + local $sortglob = *backwards_stacked; + local $sortglobr = \*backwards_stacked; + local $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); } ## exercise sort builtins... ($a <=> $b already tested) @@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $dummy; # force blockness return $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); print "# x = '$x'; expected = '$expected'\n"; { use integer; @b = sort { $a <=> $b } @a; - print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); print "# x = '@b'\n"; @b = sort { $b <=> $a } @a; - print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); print "# x = '$x'; expected = '$expected'\n"; } # test that an optimized-away comparison block doesn't take any other # arguments away with it $x = join('', sort { $a <=> $b } 3, 1, 2); -print $x eq "123" ? "ok 37\n" : "not ok 37\n"; +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; # test sorting in non-main package package Foo; @a = ( 5, 19, 1996, 255, 90 ); @b = sort { $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); print "# x = '@b'\n"; diff --git a/t/op/stat.t b/t/op/stat.t index 0af55bbaab..37237f0bdf 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -14,9 +14,10 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; +$Is_Cygwin = $^O eq 'cygwin'; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless $Is_Dosish; +$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; unlink "Op.stat.tmp"; if (open(FOO, ">Op.stat.tmp")) { @@ -163,7 +164,7 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_Dosish) { +if ($^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { print "ok 35 # skipped: no -u\n"; goto tty_test; } diff --git a/t/op/subst.t b/t/op/subst.t index 2d15df4dc1..9757f4c595 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..83\n"; +print "1..84\n"; $x = 'foo'; $_ = "x"; @@ -375,4 +375,7 @@ $x = $x = 'interp'; eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; +$_ = "C:/"; +s/^([a-z]:)/\u$1/ and print "not "; +print "ok 84\n"; diff --git a/t/op/substr.t b/t/op/substr.t index 87efcb4512..8d31a9ae61 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -1,6 +1,6 @@ #!./perl -print "1..106\n"; +print "1..108\n"; #P = start of string Q = start of substr R = end of substr S = end of string @@ -209,3 +209,9 @@ print "ok 105\n"; eval 'substr($a,0,0,"") = "abc"'; print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; print "ok 106\n"; + +$a = "abcdefgh"; +print "not " unless sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; +print "ok 107\n"; +print "not " unless $a eq 'xxxxefgh'; +print "ok 108\n"; diff --git a/t/pragma/constant.t b/t/pragma/constant.t index a56e081083..5904a4f2b6 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -14,9 +14,9 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..46\n"; } +BEGIN { $| = 1; print "1..58\n"; } END {print "not ok 1\n" unless $loaded;} -use constant; +use constant 1.01; $loaded = 1; #print "# Version: $constant::VERSION\n"; print "ok 1\n"; @@ -155,3 +155,42 @@ test 44, scalar($@ =~ /^No such pseudo-hash field/); print CCODE->(45); eval q{ CCODE->{foo} }; test 46, scalar($@ =~ /^Constant is not a HASH/); + +# Allow leading underscore +use constant _PRIVATE => 47; +test 47, _PRIVATE == 47; + +# Disallow doubled leading underscore +eval q{ + use constant __DISALLOWED => "Oops"; +}; +test 48, $@ =~ /begins with '__'/; + +# Check on declared() and %declared. This sub should be EXACTLY the +# same as the one quoted in the docs! +sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; +} + +test 49, declared 'PI'; +test 50, $constant::declared{'main::PI'}; + +test 51, !declared 'PIE'; +test 52, !$constant::declared{'main::PIE'}; + +{ + package Other; + use constant IN_OTHER_PACK => 42; + ::test 53, ::declared 'IN_OTHER_PACK'; + ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; + ::test 55, ::declared 'main::PI'; + ::test 56, $constant::declared{'main::PI'}; +} + +test 57, declared 'Other::IN_OTHER_PACK'; +test 58, $constant::declared{'Other::IN_OTHER_PACK'}; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index f673dce028..f9a9c59c87 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -759,7 +759,12 @@ else { }, 'deref'; # Hash: my @cont = sort %$deref; - test "@cont", '23 5 fake foo'; # 178 + if ("\t" eq "\011") { # ascii + test "@cont", '23 5 fake foo'; # 178 + } + else { # ebcdic alpha-numeric sort order + test "@cont", 'fake foo 23 5'; # 178 + } my @keys = sort keys %$deref; test "@keys", 'fake foo'; # 179 my @val = sort values %$deref; diff --git a/t/pragma/strict-subs b/t/pragma/strict-subs index deeb381473..ed4fe7a443 100644 --- a/t/pragma/strict-subs +++ b/t/pragma/strict-subs @@ -33,6 +33,24 @@ Execution of - aborted due to compilation errors. ######## # strict subs - error +use strict 'subs' ; +my @a = (A..Z); +EXPECT +Bareword "Z" not allowed while "strict subs" in use at - line 4. +Bareword "A" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict 'subs' ; +my $a = (B..Y); +EXPECT +Bareword "Y" not allowed while "strict subs" in use at - line 4. +Bareword "B" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error use strict ; Fred ; EXPECT diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t index 01b0f0529c..2ae8d9c784 100755 --- a/t/pragma/utf8.t +++ b/t/pragma/utf8.t @@ -4,6 +4,10 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; + if ( ord("\t") != 9 ) { # skip on ebcdic platforms + print "1..0 # Skip utf8 tests on ebcdic platform.\n"; + exit; + } } print "1..12\n"; diff --git a/t/pragma/warn/1global b/t/pragma/warn/1global index 836b7f513f..0af80221b2 100644 --- a/t/pragma/warn/1global +++ b/t/pragma/warn/1global @@ -43,7 +43,7 @@ EXPECT $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## # warnings enabled at compile time, disabled at run time @@ -59,7 +59,7 @@ BEGIN { $^W = 0 } $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w --FILE-- abcd @@ -68,7 +68,7 @@ my $b ; chop $b ; --FILE-- require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -78,7 +78,7 @@ my $b ; chop $b ; #! perl -w require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -88,7 +88,7 @@ my $b ; chop $b ; $^W =1 ; require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -110,28 +110,28 @@ $^W =0 ; require "./abcd"; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## $^W = 1; eval 'my $b ; chop $b ;' ; print $@ ; EXPECT -Use of uninitialized value at (eval 1) line 1. +Use of uninitialized value in scalar chop at (eval 1) line 1. ######## eval '$^W = 1;' ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## eval {$^W = 1;} ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## { @@ -149,12 +149,12 @@ my $a ; chop $a ; } my $c ; chop $c ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w -e undef EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in -e at - line 2. ######## $^W = 1 + 2 ; @@ -186,4 +186,4 @@ sub fred { my $b ; chop $b ;} fred() ; } EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in scalar chop at - line 2. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use index 4ec4da0a77..384b3b361e 100644 --- a/t/pragma/warn/2use +++ b/t/pragma/warn/2use @@ -42,7 +42,7 @@ use warnings 'uninitialized' ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -53,7 +53,7 @@ no warnings ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check runtime scope of pragma @@ -64,7 +64,7 @@ no warnings ; } &$a ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## use warnings 'deprecated' ; @@ -103,7 +103,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -116,7 +116,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -137,7 +137,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check scope of pragma with eval @@ -147,8 +147,8 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -159,7 +159,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -223,7 +223,7 @@ eval q[ ]; print STDERR $@; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 3. +Use of uninitialized value in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval @@ -233,8 +233,8 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -245,7 +245,7 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -303,6 +303,6 @@ no warnings 'deprecated' ; 1 if $a EQ $b ; EXPECT Use of EQ is deprecated at - line 6. -Use of uninitialized value at - line 9. -Use of uninitialized value at - line 11. -Use of uninitialized value at - line 11. +Use of uninitialized value in scalar chop at - line 9. +Use of uninitialized value in string eq at - line 11. +Use of uninitialized value in string eq at - line 11. diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both index 592724ad73..132b99b80f 100644 --- a/t/pragma/warn/3both +++ b/t/pragma/warn/3both @@ -13,7 +13,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -27,7 +27,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -64,7 +64,7 @@ $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -73,7 +73,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -107,7 +107,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## # Check interaction of $^W and use warnings @@ -119,7 +119,7 @@ sub fred { BEGIN { $^W = 0 } fred() ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -141,7 +141,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -150,7 +150,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -181,7 +181,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in scalar chop at - line 10. ######## # Check interaction of $^W and use warnings @@ -194,4 +194,4 @@ BEGIN { $^W = 0 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 7. diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint index 6a08409bb2..db54f31c7b 100644 --- a/t/pragma/warn/4lint +++ b/t/pragma/warn/4lint @@ -9,14 +9,14 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print on closed filehandle main::STDIN at - line 6. +print() on closed filehandle main::STDIN at - line 6. ######## -W # lint: check runtime $^W is zapped $^W = 0 ; close STDIN ; print STDIN "abc" ; EXPECT -print on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 4. ######## -W # lint: check runtime $^W is zapped @@ -25,7 +25,7 @@ print on closed filehandle main::STDIN at - line 4. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -W # lint: check "no warnings" is zapped @@ -35,7 +35,7 @@ $a = 1 if $a EQ $b ; close STDIN ; print STDIN "abc" ; EXPECT Use of EQ is deprecated at - line 5. -print on closed filehandle main::STDIN at - line 6. +print() on closed filehandle main::STDIN at - line 6. ######## -W # lint: check "no warnings" is zapped @@ -44,7 +44,7 @@ print on closed filehandle main::STDIN at - line 6. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -Ww # lint: check combination of -w and -W @@ -53,7 +53,7 @@ print on closed filehandle main::STDIN at - line 5. close STDIN ; print STDIN "abc" ; } EXPECT -print on closed filehandle main::STDIN at - line 5. +print() on closed filehandle main::STDIN at - line 5. ######## -W --FILE-- abc.pm @@ -67,7 +67,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -81,7 +81,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc.pm @@ -95,7 +95,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -109,4 +109,4 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. diff --git a/t/pragma/warn/7fatal b/t/pragma/warn/7fatal index fe94511f3e..943bb06fb3 100644 --- a/t/pragma/warn/7fatal +++ b/t/pragma/warn/7fatal @@ -23,7 +23,7 @@ use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -35,7 +35,7 @@ no warnings ; &$a ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## --FILE-- abc @@ -69,7 +69,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -83,7 +83,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -95,7 +95,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 6. +-- Use of uninitialized value in scalar chop at - line 6. The End. ######## @@ -107,8 +107,8 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -120,7 +120,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -178,7 +178,7 @@ eval q[ my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 3. +-- Use of uninitialized value in scalar chop at (eval 1) line 3. The End. ######## @@ -190,8 +190,8 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -203,7 +203,7 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index 5101bdef80..57dd993a2b 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -1,6 +1,6 @@ doio.c - Can't do bidirectional pipe [Perl_do_open9] + Can't open bidirectional pipe [Perl_do_open9] open(F, "| true |"); Missing command in piped open [Perl_do_open9] @@ -64,7 +64,7 @@ no warnings 'io' ; open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(G); EXPECT -Can't do bidirectional pipe at - line 3. +Can't open bidirectional pipe at - line 3. ######## # doio.c [Perl_do_open9] use warnings 'io' ; @@ -123,7 +123,7 @@ print $a ; no warnings 'uninitialized' ; print $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in print at - line 3. ######## # doio.c [Perl_my_stat Perl_my_lstat] use warnings 'io' ; diff --git a/t/pragma/warn/doop b/t/pragma/warn/doop index 961d157502..cce6bdc07c 100644 --- a/t/pragma/warn/doop +++ b/t/pragma/warn/doop @@ -12,6 +12,12 @@ EXPECT Malformed UTF-8 character at - line 4. ######## # doop.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Character codes differ on ebcdic machines."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = "\x80 \xff" ; @@ -20,6 +26,6 @@ no warnings 'utf8' ; $_ = "\x80 \xff" ; chop ; EXPECT -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. -Malformed UTF-8 character at - line 5. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. +Malformed UTF-8 character at - line 11. diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp index 48b5ec86b5..eb09e059ba 100644 --- a/t/pragma/warn/pp +++ b/t/pragma/warn/pp @@ -85,7 +85,7 @@ my $b = $$a; no warnings 'uninitialized' ; my $c = $$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar dereference at - line 4. ######## # pp.c use warnings 'unsafe' ; @@ -112,6 +112,12 @@ EXPECT Malformed UTF-8 character at - line 4. ######## # pp.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Character codes differ on ebcdic machines."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = "\x80 \xff" ; @@ -120,6 +126,6 @@ no warnings 'utf8' ; $_ = "\x80 \xff" ; reverse ; EXPECT -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. -Malformed UTF-8 character at - line 5. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. +Malformed UTF-8 character at - line 11. diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index 70e6d60e8d..f61da1a8e1 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -126,7 +126,7 @@ no warnings 'unsafe' ; @b = sort { last } @a ; EXPECT Exiting pseudo-block via last at - line 4. -Can't "last" outside a block at - line 4. +Can't "last" outside a loop block at - line 4. ######## # pp_ctl.c use warnings 'unsafe' ; diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 9a4b0a0708..7e19dc5c94 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -9,7 +9,7 @@ Filehandle %s opened only for output [pp_print] print <STDOUT> ; - print on closed filehandle %s [pp_print] + print() on closed filehandle %s [pp_print] close STDIN ; print STDIN "abc" ; uninitialized [pp_rv2av] @@ -30,7 +30,7 @@ glob failed (can't start child: %s) [Perl_do_readline] <<TODO - Read on closed filehandle %s [Perl_do_readline] + readline() on closed filehandle %s [Perl_do_readline] close STDIN ; $a = <STDIN>; glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO @@ -86,7 +86,7 @@ print STDIN "anc"; no warnings 'closed' ; print STDIN "anc"; EXPECT -print on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 4. ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; @@ -95,7 +95,7 @@ my @b = @$a; no warnings 'uninitialized' ; my @c = @$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in array dereference at - line 4. ######## # pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; @@ -104,7 +104,7 @@ my %b = %$a; no warnings 'uninitialized' ; my %c = %$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in hash dereference at - line 4. ######## # pp_hot.c [pp_aassign] use warnings 'unsafe' ; @@ -128,7 +128,7 @@ close STDIN ; $a = <STDIN> ; no warnings 'closed' ; $a = <STDIN> ; EXPECT -Read on closed filehandle main::STDIN at - line 3. +readline() on closed filehandle main::STDIN at - line 3. ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 651cdf9515..ea4b536842 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -8,7 +8,7 @@ . write STDIN; - Write on closed filehandle %s [pp_leavewrite] + write() on closed filehandle %s [pp_leavewrite] format STDIN = . close STDIN; @@ -23,45 +23,47 @@ $a = "abc"; printf $a "fred" - printf on closed filehandle %s [pp_prtf] + printf() on closed filehandle %s [pp_prtf] close STDIN ; printf STDIN "fred" - Syswrite on closed filehandle [pp_send] + syswrite() on closed filehandle [pp_send] close STDIN; syswrite STDIN, "fred", 1; - Send on closed socket [pp_send] + send() on closed socket [pp_send] close STDIN; send STDIN, "fred", 1 - bind() on closed fd [pp_bind] + bind() on closed socket [pp_bind] close STDIN; bind STDIN, "fred" ; - connect() on closed fd [pp_connect] + connect() on closed socket [pp_connect] close STDIN; connect STDIN, "fred" ; - listen() on closed fd [pp_listen] + listen() on closed socket [pp_listen] close STDIN; listen STDIN, 2; - accept() on closed fd [pp_accept] + accept() on closed socket [pp_accept] close STDIN; accept STDIN, "fred" ; - shutdown() on closed fd [pp_shutdown] + shutdown() on closed socket [pp_shutdown] close STDIN; shutdown STDIN, 0; - [gs]etsockopt() on closed fd [pp_ssockopt] + setsockopt() on closed socket [pp_ssockopt] + getsockopt() on closed socket [pp_ssockopt] close STDIN; setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; - get{sock, peer}name() on closed fd [pp_getpeername] + getsockname() on closed socket [pp_getpeername] + getpeername() on closed socket [pp_getpeername] close STDIN; getsockname STDIN; getpeername STDIN; @@ -112,7 +114,7 @@ write STDIN; no warnings 'closed' ; write STDIN; EXPECT -Write on closed filehandle main::STDIN at - line 6. +write() on closed filehandle main::STDIN at - line 6. ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; @@ -148,7 +150,7 @@ printf STDIN "fred"; no warnings 'closed' ; printf STDIN "fred"; EXPECT -printf on closed filehandle main::STDIN at - line 4. +printf() on closed filehandle main::STDIN at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'io' ; @@ -165,7 +167,7 @@ syswrite STDIN, "fred", 1; no warnings 'closed' ; syswrite STDIN, "fred", 1; EXPECT -Syswrite on closed filehandle at - line 4. +syswrite() on closed filehandle at - line 4. ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; @@ -210,16 +212,16 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; EXPECT -Send on closed socket at - line 22. -bind() on closed fd at - line 23. -connect() on closed fd at - line 24. -listen() on closed fd at - line 25. -accept() on closed fd at - line 26. -shutdown() on closed fd at - line 27. -[gs]etsockopt() on closed fd at - line 28. -[gs]etsockopt() on closed fd at - line 29. -get{sock, peer}name() on closed fd at - line 30. -get{sock, peer}name() on closed fd at - line 31. +send() on closed socket at - line 22. +bind() on closed socket at - line 23. +connect() on closed socket at - line 24. +listen() on closed socket at - line 25. +accept() on closed socket at - line 26. +shutdown() on closed socket at - line 27. +setsockopt() on closed socket at - line 28. +getsockopt() on closed socket at - line 29. +getsockname() on closed socket at - line 30. +getpeername() on closed socket at - line 31. ######## # pp_sys.c [pp_stat] use warnings 'newline' ; diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 92b8208a65..bb208db6bd 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -68,6 +68,7 @@ no warnings 'unsafe' ; /[[.foo.]]/; /[[=bar=]]/; /[:zog:]/; +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } /[[:zog:]]/; EXPECT Character class syntax [: :] belongs inside character classes at - line 4. @@ -78,7 +79,7 @@ Character class syntax [= =] is reserved for future extensions at - line 6. Character class syntax [. .] is reserved for future extensions at - line 8. Character class syntax [= =] is reserved for future extensions at - line 9. Character class syntax [: :] belongs inside character classes at - line 10. -Character class [:zog:] unknown at - line 19. +Character class [:zog:] unknown at - line 20. ######## # regcomp.c [S_regclass] $_ = ""; @@ -113,6 +114,12 @@ EXPECT /[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. ######## # regcomp.c [S_regclassutf8] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic regular expression ranges differ."; + exit 0; + } +} use utf8; $_ = ""; use warnings 'unsafe' ; @@ -136,14 +143,14 @@ no warnings 'unsafe' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[a-\d]/: false [] range "a-\d" in regexp at - line 6. -/[\d-b]/: false [] range "\d-" in regexp at - line 7. -/[\s-\d]/: false [] range "\s-" in regexp at - line 8. -/[\d-\s]/: false [] range "\d-" in regexp at - line 9. -/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 10. -/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 11. -/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 12. -/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 13. +/[a-\d]/: false [] range "a-\d" in regexp at - line 12. +/[\d-b]/: false [] range "\d-" in regexp at - line 13. +/[\s-\d]/: false [] range "\s-" in regexp at - line 14. +/[\d-\s]/: false [] range "\d-" in regexp at - line 15. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19. ######## # regcomp.c [S_regclass S_regclassutf8] use warnings 'unsafe' ; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index c02ff01b82..97d61bca17 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -58,7 +58,7 @@ $x = 1 + $a[0] ; # a no warnings 'uninitialized' ; $x = 1 + $b[0] ; # a EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer addition (+) at - line 4. ######## # sv.c (sv_2iv) package fred ; @@ -73,7 +73,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in integer multiplication (*) at - line 10. ######## # sv.c use integer ; @@ -82,7 +82,7 @@ my $x *= 2 ; #b no warnings 'uninitialized' ; my $y *= 2 ; #b EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer multiplication (*) at - line 4. ######## # sv.c (sv_2uv) package fred ; @@ -98,7 +98,7 @@ no warnings 'uninitialized' ; $B = 0 ; $B |= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in bitwise or (|) at - line 10. ######## # sv.c use warnings 'uninitialized' ; @@ -108,7 +108,7 @@ no warnings 'uninitialized' ; my $Y = 1 ; $x = 1 | $b[$Y] ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in bitwise or (|) at - line 4. ######## # sv.c use warnings 'uninitialized' ; @@ -116,7 +116,7 @@ my $x *= 1 ; # d no warnings 'uninitialized' ; my $y *= 1 ; # d EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in multiplication (*) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -124,7 +124,7 @@ $x = 1 + $a[0] ; # e no warnings 'uninitialized' ; $x = 1 + $b[0] ; # e EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c (sv_2nv) package fred ; @@ -138,7 +138,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 9. +Use of uninitialized value in multiplication (*) at - line 9. ######## # sv.c use warnings 'uninitialized' ; @@ -146,7 +146,7 @@ $x = $y + 1 ; # f no warnings 'uninitialized' ; $x = $z + 1 ; # f EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -162,7 +162,7 @@ $x = chop $y ; # h no warnings 'uninitialized' ; $x = chop $z ; # h EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # sv.c (sv_2pv) package fred ; @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in concatenation (.) at - line 10. ######## # sv.c use warnings 'numeric' ; @@ -269,6 +269,12 @@ EXPECT Undefined value assigned to typeglob at - line 3. ######## # sv.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic \\x characters differ."; + exit 0; + } +} use utf8 ; $^W =0 ; { @@ -279,9 +285,9 @@ $^W =0 ; } my $a = rindex "a\xff bc ", "bc" ; EXPECT -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 6. -Malformed UTF-8 character at - line 6. -Malformed UTF-8 character at - line 10. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 12. +Malformed UTF-8 character at - line 12. +Malformed UTF-8 character at - line 16. ######## # sv.c use warnings 'misc'; diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index ee02efa813..515241ab4d 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -462,13 +462,19 @@ EXPECT ######## # toke.c +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use warnings 'utf8' ; use utf8 ; $_ = " \xffe " ; no warnings 'utf8' ; $_ = " \xffe " ; EXPECT -\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 10. ######## # toke.c my $a = rand + 4 ; diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 index b11514d826..19b8d1db3a 100644 --- a/t/pragma/warn/utf8 +++ b/t/pragma/warn/utf8 @@ -22,6 +22,12 @@ EXPECT Malformed UTF-8 character at - line 3. ######## # utf8.c [utf8_to_uv] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use utf8 ; my $a = ord "\x80" ; { @@ -31,9 +37,9 @@ my $a = ord "\x80" ; my $a = ord "\x80" ; } EXPECT -Malformed UTF-8 character at - line 3. -\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 6. -Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 9. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 12. +Malformed UTF-8 character at - line 12. ######## # utf8.c [utf8_to_uv] use utf8 ; @@ -42,6 +48,12 @@ EXPECT Malformed UTF-8 character at - line 3. ######## # utf8.c [utf8_to_uv] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# Ebcdic platforms have different \\x constructs."; + exit 0; + } +} use utf8 ; my $a = ord "\xf080" ; { @@ -51,6 +63,6 @@ my $a = ord "\xf080" ; my $a = ord "\xf080" ; } EXPECT -Malformed UTF-8 character at - line 3. -\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 6. -Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 9. +\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 12. +Malformed UTF-8 character at - line 12. |