diff options
| author | markm <markm@FreeBSD.org> | 2002-03-16 20:14:30 +0000 |
|---|---|---|
| committer | markm <markm@FreeBSD.org> | 2002-03-16 20:14:30 +0000 |
| commit | 3eac21f49bc763a6c0044b4afbc0c7ece760144f (patch) | |
| tree | 4cf1274fa3ca68f7ecf6a3051e0c2243e378afc5 /contrib/perl5/t | |
| parent | 259bd53c06712c4ffb0ab7e06898c19ebf221b21 (diff) | |
| download | FreeBSD-src-3eac21f49bc763a6c0044b4afbc0c7ece760144f.zip FreeBSD-src-3eac21f49bc763a6c0044b4afbc0c7ece760144f.tar.gz | |
Vendor import Perl 5.6.1
Diffstat (limited to 'contrib/perl5/t')
221 files changed, 6032 insertions, 1498 deletions
diff --git a/contrib/perl5/t/README b/contrib/perl5/t/README index 8384349..0953026 100644 --- a/contrib/perl5/t/README +++ b/contrib/perl5/t/README @@ -13,4 +13,4 @@ will fail, you may want to use Test::Harness thusly: ./perl -I../lib harness This method pinpoints failed tests automatically. -If you come up with new tests, please send them to larry@wall.org. +If you come up with new tests, please send them to perlbug@perl.org. diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST index 0b674af..bce9545 100755 --- a/contrib/perl5/t/TEST +++ b/contrib/perl5/t/TEST @@ -24,10 +24,10 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 if ($#ARGV == -1) { @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); + `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); } -%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); _testprogs('perl', @ARGV); _testprogs('compile', @ARGV) if (-e "../testcompile"); @@ -90,9 +90,10 @@ EOT open(RESULTS,"./perl$switch $test |") or print "can't run.\n"; } else { - open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test " - ."-run -verbose dcf -log ../compilelog |") + open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " + ." && ./$test.plc |") or print "can't compile.\n"; + unlink "./$test.plc"; } $ok = 0; diff --git a/contrib/perl5/t/UTEST b/contrib/perl5/t/UTEST index b5f285b..9c1dfc0 100755 --- a/contrib/perl5/t/UTEST +++ b/contrib/perl5/t/UTEST @@ -81,7 +81,10 @@ EOT if ($type eq 'perl') { open(RESULTS, "./$test |") || (print "can't run.\n"); } else { - open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test -run -verbose dcf -log ../compilelog |") or print "can't compile.\n"; + open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " + ." && ./$test.plc |") + or print "can't compile.\n"; + unlink "./$test.plc"; } } else { diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t index d90d404..c7fb0e4 100755 --- a/contrib/perl5/t/base/lex.t +++ b/contrib/perl5/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..46\n"; +print "1..51\n"; $x = 'x'; @@ -206,3 +206,42 @@ EOT print "# $@\nnot ok $test\n" if $@; T '^main:plink:53$', $test++; } + +# tests 47--51 start here +# tests for new array interpolation semantics: +# arrays now *always* interpolate into "..." strings. +# 20000522 MJD (mjd@plover.com) +{ + my $test = 47; + eval(q(">@nosuch<" eq "><")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Look at this! This is going to be a common error in the future: + eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Let's make sure that normal array interpolation still works right + # For some reason, this appears not to be tested anywhere else. + my @a = (1,2,3); + print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; + ++$test; + + # Ditto. + eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # This isn't actually a lex test, but it's testing the same feature + sub makearray { + my @array = ('fish', 'dog', 'carrot'); + *R::crackers = \@array; + } + + eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; +} diff --git a/contrib/perl5/t/base/rs.t b/contrib/perl5/t/base/rs.t index 021d699..e470f3a 100755 --- a/contrib/perl5/t/base/rs.t +++ b/contrib/perl5/t/base/rs.t @@ -6,6 +6,8 @@ print "1..14\n"; $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; # Create our test datafile +1 while unlink 'foo'; # in case junk left around +rmdir 'foo'; open TESTFILE, ">./foo" or die "error $! $^E opening"; binmode TESTFILE; print TESTFILE $teststring; diff --git a/contrib/perl5/t/base/term.t b/contrib/perl5/t/base/term.t index 6380694..818eb71 100755 --- a/contrib/perl5/t/base/term.t +++ b/contrib/perl5/t/base/term.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -51,5 +51,5 @@ else { die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; } -open(try, "../Configure") || (die "Can't open ../Configure."); +open(try, "harness") || (die "Can't open harness."); if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/contrib/perl5/t/comp/bproto.t b/contrib/perl5/t/comp/bproto.t index 01efb84..70748be 100755 --- a/contrib/perl5/t/comp/bproto.t +++ b/contrib/perl5/t/comp/bproto.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..10\n"; diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t index dee5330..d2c64fe 100755 --- a/contrib/perl5/t/comp/colon.t +++ b/contrib/perl5/t/comp/colon.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t index bbff38c..5b061ee 100755 --- a/contrib/perl5/t/comp/cpp.t +++ b/contrib/perl5/t/comp/cpp.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t index ee17088..99dd3ea 100755 --- a/contrib/perl5/t/comp/proto.t +++ b/contrib/perl5/t/comp/proto.t @@ -11,12 +11,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; -print "1..107\n"; +print "1..122\n"; my $i = 1; @@ -293,6 +293,25 @@ printf "ok %d\n",$i++; ## ## +testing \&a_subx, '\&'; + +sub a_subx (\&) { + print "# \@_ = (",join(",",@_),")\n"; + &{$_[0]}; +} + +sub tmp_sub_2 { printf "ok %d\n",$i++ } +a_subx &tmp_sub_2; + +@array = ( \&tmp_sub_2 ); +eval 'a_subx @array'; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + testing \&sub_aref, '&\@'; sub sub_aref (&\@) { @@ -466,3 +485,14 @@ sub sreftest (\$$) { sreftest($helem{$i}, $i++); sreftest $aelem[0], $i++; } + +# test prototypes when they are evaled and there is a syntax error +# +for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { + no warnings 'redefine'; + my $eval = "sub evaled_subroutine $p { &void *; }"; + eval $eval; + # The /Syntax error/ is seen on OS/390. It's /syntax error/ elsewhere + print "# eval[$eval]\nnot " unless $@ && $@ =~ /[Ss]yntax error/; + print "ok ", $i++, "\n"; +} diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t index 1d92687..1b0af9f 100755 --- a/contrib/perl5/t/comp/require.t +++ b/contrib/perl5/t/comp/require.t @@ -2,12 +2,21 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, ('.', '../lib'); + @INC = '.'; + push @INC, '../lib'; } # don't make this lexical $i = 1; -print "1..20\n"; +# Tests 21 .. 23 work only with non broken UTF16-as-code implementations, +# i.e. not EBCDIC Perls. +my $Is_EBCDIC = ord('A') == 193 ? 1 : 0; +if ($Is_EBCDIC) { + print "1..20\n"; +} +else { + print "1..23\n"; +} sub do_require { %INC = (); @@ -19,6 +28,8 @@ sub do_require { sub write_file { my $f = shift; open(REQ,">$f") or die "Can't write '$f': $!"; + binmode REQ; + use bytes; print REQ @_; close REQ; } @@ -122,7 +133,21 @@ do "bleah.do"; dofile(); sub dofile { do "bleah.do"; }; print $x; -$i++; + +exit if $Is_EBCDIC; + +# UTF-encoded things +my $utf8 = chr(0xFEFF); + +$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n)); + +sub bytes_to_utf16 { + my $utf16 = pack("$_[0]*", unpack("C*", $_[1])); + return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; +} + +$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE +$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; } diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t index 1f5fae3..fb59777 100755 --- a/contrib/perl5/t/comp/use.t +++ b/contrib/perl5/t/comp/use.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..27\n"; diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness index e1a4dd7..c24d46f 100644 --- a/contrib/perl5/t/harness +++ b/contrib/perl5/t/harness @@ -42,12 +42,12 @@ foreach (keys %datahandle) { Test::Harness::runtests @tests; exit(0) unless -e "../testcompile"; -%infinite = qw ( - op/bop.t 1 - lib/hostname.t 1 - op/lex_assign.t 1 - lib/ph.t 1 - ); +# %infinite = qw ( +# op/bop.t 1 +# lib/hostname.t 1 +# op/lex_assign.t 1 +# lib/ph.t 1 +# ); my $dhwrapper = <<'EOT'; open DATA,"<".__FILE__; diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index d6093f9..2b8f23b 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..20\n"; +print "1..21\n"; use File::Spec; @@ -107,18 +107,20 @@ print "ok 15\n"; local $/; open F, 'Io_argv1.tmp' or die; <F>; # set $. = 1 + print "not " if defined(<F>); # should hit eof + print "ok 16\n"; 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"; + print "not " if defined(<F>); + print "ok 19\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"; + print "not " if defined(<F>); + print "ok 21\n"; close F; } diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index 970e2f3..8170b33 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -115,7 +115,15 @@ if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32') {print "ok 18 # skipped: granularity of the filetime\n";} elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} -else +elsif ($^O =~ /\blinux\b/i) { + # Maybe stat() cannot get the correct atime, as happens via NFS on linux? + $foo = (utime 400000000,500000000 + 2*$delta,'b'); + my ($new_atime, $new_mtime) = (stat('b'))[8,9]; + if ($new_atime == $atime && $new_mtime - $mtime == $delta) + {print "ok 18 # accounted for possible NFS/glibc2.2 bug on linux\n";} + else + {print "not ok 18 $atime/$new_atime $mtime/$new_mtime\n";} +} else {print "not ok 18 $atime $mtime\n";} if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";} @@ -129,10 +137,15 @@ chdir $wd || die "Can't cd back to $wd"; unlink 'c'; if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links - if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";} - $foo = `grep perl c`; + system("cp TEST TEST$$"); + # we have to copy because e.g. GNU grep gets huffy if we have + # a symlink forest to another disk (it complains about too many + # levels of symbolic links, even if we have only two) + if (symlink("TEST$$","c")) {print "ok 21\n";} else {print "not ok 21\n";} + $foo = `grep perl c 2>&1`; if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} unlink 'c'; + unlink("TEST$$"); } else { print "ok 21\nok 22\n"; diff --git a/contrib/perl5/t/io/open.t b/contrib/perl5/t/io/open.t index 30db598..0e2d57c 100755 --- a/contrib/perl5/t/io/open.t +++ b/contrib/perl5/t/io/open.t @@ -2,13 +2,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # $RCSfile$ $| = 1; use warnings; $Is_VMS = $^O eq 'VMS'; +$Is_Dos = $^O eq 'dos'; print "1..66\n"; @@ -268,13 +269,21 @@ ok; { local *F; for (1..2) { - open(F, "echo #foo|") or print "not "; + if ($Is_Dos) { + open(F, "echo \\#foo|") or print "not "; + } else { + open(F, "echo #foo|") or print "not "; + } print <F>; close F; } ok; for (1..2) { - open(F, "-|", "echo #foo") or print "not "; + if ($Is_Dos) { + open(F, "-|", "echo \\#foo") or print "not "; + } else { + open(F, "-|", "echo #foo") or print "not "; + } print <F>; close F; } diff --git a/contrib/perl5/t/io/openpid.t b/contrib/perl5/t/io/openpid.t index 80c6bde..7c04a29 100755 --- a/contrib/perl5/t/io/openpid.t +++ b/contrib/perl5/t/io/openpid.t @@ -9,17 +9,15 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; if ($^O eq 'dos') { print "1..0 # Skip: no multitasking\n"; exit 0; } } - -use FileHandle; use Config; -autoflush STDOUT 1; +$| = 1; $SIG{PIPE} = 'IGNORE'; print "1..10\n"; @@ -33,10 +31,8 @@ $perl = qq[$^X "-I../lib"]; # the other reader reads one line, waits a few seconds and then # exits to test the waitpid function. # -$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[first process\\n]; sleep 30;"/; -$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . - qq/print qq[second process\\n]; sleep 30;"/; +$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; +$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; $cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN $cmd4 = qq/$perl -e "print scalar <>;"/; @@ -76,9 +72,9 @@ print "not " unless $kill_cnt == 2; print "ok 8\n"; # send one expected line of text to child process and then wait for it -autoflush FH4 1; +select(FH4); $| = 1; select(STDOUT); + print FH4 "ok 9\n"; -print "ok 9 # skip VMS\n" if $^O eq 'VMS'; print "# waiting for process $pid4 to exit\n"; $reap_pid = waitpid $pid4, 0; print "# reaped pid $reap_pid != $pid4\nnot " diff --git a/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t index 4559624..96935e3 100755 --- a/contrib/perl5/t/io/pipe.t +++ b/contrib/perl5/t/io/pipe.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'}) { print "1..0 # Skip: no fork\n"; diff --git a/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t index b89aefb..c840c92 100755 --- a/contrib/perl5/t/io/tell.t +++ b/contrib/perl5/t/io/tell.t @@ -2,14 +2,14 @@ # $RCSfile: tell.t,v $$Revision$$Date$ -print "1..21\n"; +print "1..23\n"; $TST = 'tst'; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin'); -open($TST, '../Configure') || (die "Can't open ../Configure"); +open($TST, 'harness') || (die "Can't open harness"); binmode $TST if $Is_Dosish; if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } @@ -49,7 +49,7 @@ unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } $curline = $.; -open(other, '../Configure') || (die "Can't open ../Configure"); +open(other, 'harness') || (die "Can't open harness: $!"); binmode other if $^O eq 'MSWin32'; { @@ -82,3 +82,13 @@ if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } tell other; if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } } + +close(other); +if (tell(other) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; } + +if (tell(ether) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; } + +# ftell(STDIN) (or any std streams) is undefined, it can return -1 or +# something else. ftell() on pipes, fifos, and sockets is defined to +# return -1. + diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t index 05e5c70..fb5a984 100755 --- a/contrib/perl5/t/lib/abbrev.t +++ b/contrib/perl5/t/lib/abbrev.t @@ -4,7 +4,7 @@ print "1..7\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Abbrev; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t index 3e16dce..f38e905 100755 --- a/contrib/perl5/t/lib/ansicolor.t +++ b/contrib/perl5/t/lib/ansicolor.t @@ -1,8 +1,6 @@ -#!./perl - BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Test suite for the Term::ANSIColor Perl module. Before `make install' is @@ -13,7 +11,7 @@ BEGIN { # Ensure module can be loaded ############################################################################ -BEGIN { $| = 1; print "1..7\n" } +BEGIN { $| = 1; print "1..8\n" } END { print "not ok 1\n" unless $loaded } use Term::ANSIColor qw(:constants color colored); $loaded = 1; @@ -71,3 +69,13 @@ if (colored ("test\ntest\r\r\n\r\n", 'bold') } else { print "not ok 7\n"; } + +# Test the array ref form. +$Term::ANSIColor::EACHLINE = "\n"; +if (colored (['bold', 'on_green'], "test\n", "\n", "test") + eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { + print "ok 8\n"; +} else { + print colored (['bold', 'on_green'], "test\n", "\n", "test"); + print "not ok 8\n"; +} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t index e38c7e7..40c4366 100755 --- a/contrib/perl5/t/lib/anydbm.t +++ b/contrib/perl5/t/lib/anydbm.t @@ -4,10 +4,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; + exit 0; + } } require AnyDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; print "1..12\n"; diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t index eb8c8c4..440122c 100755 --- a/contrib/perl5/t/lib/attrs.t +++ b/contrib/perl5/t/lib/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; eval 'require attrs; 1' or do { print "1..0\n"; exit 0; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t index 3bf690b..b53b9fe 100755 --- a/contrib/perl5/t/lib/autoloader.t +++ b/contrib/perl5/t/lib/autoloader.t @@ -3,7 +3,8 @@ BEGIN { chdir 't' if -d 't'; $dir = "auto-$$"; - unshift @INC, ("./$dir", "../lib"); + @INC = $dir; + push @INC, '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t index 478e26a..9bee1bf 100755 --- a/contrib/perl5/t/lib/basename.t +++ b/contrib/perl5/t/lib/basename.t @@ -2,12 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Basename qw(fileparse basename dirname); -print "1..36\n"; +print "1..41\n"; # import correctly? print +(defined(&basename) && !defined(&fileparse_set_fstype) ? @@ -96,29 +96,34 @@ print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? '' : 'not '),"ok 25\n"; print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? '' : 'not '),"ok 26\n"; -print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 27\n"; -print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n"; +print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; +print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; +print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; +print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; +print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; # Check quoting of metacharacters in suffix arg by basename() print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 29\n"; + '' : 'not '),"ok 34\n"; print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 30\n"; + '' : 'not '),"ok 35\n"; # extra tests for a few specific bugs File::Basename::fileparse_set_fstype 'MSDOS'; # perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; # perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; File::Basename::fileparse_set_fstype 'UNIX'; # perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; # perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; # The empty tainted value, for tainting strings my $TAINT = substr($^X, 0, 0); @@ -134,6 +139,6 @@ sub all_tainted (@) { 1; } -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n"; +print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 36\n"; + ? '' : 'not '), "ok 41\n"; diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t index 5d97f1b..aa45651 100755 --- a/contrib/perl5/t/lib/bigfltpm.t +++ b/contrib/perl5/t/lib/bigfltpm.t @@ -9,7 +9,7 @@ use Math::BigFloat; $test = 0; $| = 1; -print "1..362\n"; +print "1..370\n"; while (<DATA>) { chop; if (s/^&//) { @@ -51,6 +51,8 @@ while (<DATA>) { $try .= "\$x * \$y;"; } elsif ($f eq "fdiv") { $try .= "\$x / \$y;"; + } elsif ($f eq "fmod") { + $try .= "\$x % \$y;"; } else { warn "Unknown op"; } } #print ">>>",$try,"<<<\n"; @@ -65,22 +67,26 @@ while (<DATA>) { print "# '$try' expected: /$pat/ got: '$ans1'\n"; } } - elsif ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } + else { + + $ans1_str = defined $ans1? "$ans1" : ""; + if ($ans1_str eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } } -} +} __END__ &fnorm -abc:NaN. - 1 a:NaN. -1bcd2:NaN. -11111b:NaN. -+1z:NaN. --1z:NaN. +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN 0:0. +0:0. +00:0. @@ -98,7 +104,7 @@ abc:NaN. -001:-1. -123456789:-123456789. -00000100000:-100000. -123.456a:NaN. +123.456a:NaN 123.456:123.456 0.01:.01 .002:.002 @@ -113,7 +119,7 @@ abc:NaN. -3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. -4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 &fneg -abd:NaN. +abc:NaN +0:0. +1:-1. -1:1. @@ -122,7 +128,7 @@ abd:NaN. +123.456789:-123.456789 -123456.789:123456.789 &fabs -abc:NaN. +abc:NaN +0:0. +1:1. -1:1. @@ -249,13 +255,13 @@ $Math::BigFloat::rnd_mode = 'even' -6.23:-1:/-6.2(?:0{5}\d+)? +6.27:-1:/6.(?:3|29{5}\d+) -6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.2(?:0{5}\d+)? --6.25:-1:/-6.2(?:0{5}\d+)? -+6.35:-1:/6.(?:4|39{5}\d+) --6.35:-1:/-6.(?:4|39{5}\d+) ++6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) +-6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) ++6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) -0.0065:-1:0 -0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 +-0.0065:-3:/-0\.006|-7e-03 -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 &fcmp @@ -286,9 +292,9 @@ abc:+0: -123:-124:1 -124:-123:-1 &fadd -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:1. @@ -324,9 +330,9 @@ abc:+0:NaN. -123456789:-987654321:-1111111110. +123456789:-987654321:-864197532. &fsub -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:-1. @@ -362,9 +368,9 @@ abc:+0:NaN. -123456789:-987654321:864197532. +123456789:-987654321:1111111110. &fmul -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +0:+1:0. +1:+0:0. @@ -395,14 +401,14 @@ abc:+0:NaN. +88888888888:+9:799999999992. +99999999999:+9:899999999991. &fdiv -abc:abc:NaN. -abc:+1:abc:NaN. -+1:abc:NaN. -+0:+0:NaN. +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN +0:+1:0. -+1:+0:NaN. ++1:+0:NaN +0:-1:0. --1:+0:NaN. +-1:+0:NaN +1:+1:1. -1:-1:1. +1:-1:-1. @@ -461,3 +467,12 @@ $Math::BigFloat::div_scale = 40 +100:10. +123.456:11.11107555549866648462149404118219234119 +15241.383936:123.456 +&fmod ++0:0:NaN ++0:1:0. ++3:1:0. ++5:2:1. ++9:4:1. ++9:5:4. ++9000:56:40. ++56:9000:56. diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t index d2d520e..034c5c6 100755 --- a/contrib/perl5/t/lib/bigint.t +++ b/contrib/perl5/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } require "bigint.pl"; $test = 0; diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t index ae362e2..e76f246 100755 --- a/contrib/perl5/t/lib/bigintpm.t +++ b/contrib/perl5/t/lib/bigintpm.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::BigInt; diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t index e3cba5f..2922903 100755 --- a/contrib/perl5/t/lib/cgi-form.t +++ b/contrib/perl5/t/lib/cgi-form.t @@ -1,13 +1,14 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + BEGIN {$| = 1; print "1..17\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug'); @@ -23,6 +24,15 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -33,49 +43,48 @@ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; $ENV{SERVER_PORT} = 8080; $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -test(2,start_form(-action=>'foobar',-method=>GET) eq - qq(<FORM METHOD="GET" ACTION="foobar" ENCTYPE="application/x-www-form-urlencoded">\n), +test(2,start_form(-action=>'foobar',-method=>'get') eq + qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), "start_form()"); -test(3,submit() eq qq(<INPUT TYPE="submit" NAME=".submit">),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">), +test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); +test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); +test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); +test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); +test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); +test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather), +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), "checkbox()"); test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast), + qq(<input type="checkbox" name="weather" value="nice" />forecast), "checkbox()"); test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="nice" checked />forecast), "checkbox()"); test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="dull" checked />forecast), "checkbox()"); test(13,radio_group(-name=>'game') eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>ping pong <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers" CHECKED>checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage">cribbage), + qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), 'checkbox_group()'); -test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers">checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess">chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage" CHECKED>cribbage), +test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq + qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), 'checkbox_group()'); - -test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<SELECT NAME="game"> -<OPTION VALUE="checkers">checkers -<OPTION VALUE="chess">chess -<OPTION SELECTED VALUE="cribbage">cribbage -</SELECT> +test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); +<select name="game"> +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected value="cribbage">cribbage</option> +</select> END diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t index b4cd568..3b9722e 100755 --- a/contrib/perl5/t/lib/cgi-function.t +++ b/contrib/perl5/t/lib/cgi-function.t @@ -1,14 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..24\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..27\n"; } END {print "not ok 1\n" unless $loaded;} use Config; use CGI (':standard','keywords'); @@ -24,6 +25,22 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; + +# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS +# is that a CR character gets inserted automatically in the web server +# case but not internal to perl's double quoted strings "\n". This +# test would need to be modified to use the "\015\012" on VMS if it +# were actually run through a web server. +# Thanks to Peter Prymmer for this + +if ($^O eq 'VMS') { $CRLF = "\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -36,7 +53,7 @@ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; $ENV{HTTP_LOVE} = 'true'; test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(4,param() == 2,"CGI::param()"); test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); test(6,param('game') eq 'chess',"CGI::param()"); @@ -44,18 +61,18 @@ test(7,param('weather') eq 'dull',"CGI::param()"); test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(12,http('love') eq 'true',"CGI::http()"); test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); Delete('foo'); test(20,!param('foo'),'CGI::delete()'); @@ -65,21 +82,25 @@ $ENV{QUERY_STRING}='mary+had+a+little+lamb'; test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (23,24) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - CGI::_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()"); +CGI::_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); +} else { + print "ok 23 # Skip\n"; + print "ok 24 # Skip\n"; } +test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); +my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); +test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); +test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 43d41ec..93e5dac 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -1,15 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; - require Config; import Config; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..20\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..24\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; @@ -17,8 +17,14 @@ print "ok 1\n"; ######################### End of black magic. -my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; -my $crlf = $CGI::CRLF; +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + # util sub test { @@ -28,48 +34,62 @@ sub test { } # all the automatic tags -test(2,h1() eq '<H1>',"single tag"); -test(3,h1('fred') eq '<H1>fred</H1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<H1>fred agnes maura</H1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<H1 ALIGN="CENTER">fred</H1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<H1 ALIGN>fred</H1>',"open/close tag with orphan attribute"); +test(2,h1() eq '<h1 />',"single tag"); +test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); +test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); +test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); +test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<H1 ALIGN="CENTER">fred</H1> <H1 ALIGN="CENTER">agnes</H1>', + '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', "distributive tag with attribute"); { local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation"); + test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); } - -test(9,header() eq "Content-Type: text/html$crlf$crlf","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif$crlf$crlf","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif$crlf$crlf","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html$crlf$crlf","header()"); +test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); test(13,start_html() ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML 3.2//FR"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>The world of foo</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> +</head><body> END ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq - 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s, - "header(-cookie)"); -test(18,start_h3 eq '<H3>'); -test(19,end_h3 eq '</H3>'); -test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); - - - +test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); +my $h = header(-Cookie=>$cookie); +test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie)"); +test(18,start_h3 eq '<h3>'); +test(19,end_h3 eq '</h3>'); +test(20,start_table({-border=>undef}) eq '<table border>'); +test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +charset('utf-8'); +if (ord("\t") == 9) { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +} +else { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>'); +} +test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); +my $q = new CGI; +test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t index 9e8cdc2..fde3fd0 100755 --- a/contrib/perl5/t/lib/cgi-request.t +++ b/contrib/perl5/t/lib/cgi-request.t @@ -1,17 +1,18 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..31\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..33\n"; } END {print "not ok 1\n" unless $loaded;} -use Config; use CGI (); +use Config; $loaded = 1; print "ok 1\n"; @@ -39,7 +40,7 @@ $ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()"); test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(5,$q->param() == 2,"CGI::param()"); test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); test(7,$q->param('game') eq 'chess',"CGI::param()"); @@ -47,18 +48,18 @@ test(8,$q->param('weather') eq 'dull',"CGI::param()"); test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(13,$q->http('love') eq 'true',"CGI::http()"); test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); $q->delete('foo'); test(21,!$q->param('foo'),'CGI::delete()'); @@ -73,22 +74,30 @@ test(26,$q->param('foo') eq 'bar','CGI::param() redux'); test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (29..31) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - $q->_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(29,$q=new CGI,"CGI::new() from POST"); - test(30,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(31,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +# test tied interface +my $p = $q->Vars; +test(29,$p->{bar} eq 'froz',"tied interface fetch"); +$p->{bar} = join("\0",qw(foo bar baz)); +test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); + +# test posting +$q->_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(31,$q=new CGI,"CGI::new() from POST"); + test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} else { + print "ok 31 # Skip\n"; + print "ok 32 # Skip\n"; + print "ok 33 # Skip\n"; } diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t index 7643390..2731136 100755 --- a/contrib/perl5/t/lib/charnames.t +++ b/contrib/perl5/t/lib/charnames.t @@ -3,12 +3,12 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } $| = 1; -print "1..12\n"; +print "1..15\n"; use charnames ':full'; @@ -42,15 +42,21 @@ EOE $encoded_be = "\320\261"; $encoded_alpha = "\316\261"; $encoded_bet = "\327\221"; +$encoded_deseng = "\360\220\221\215"; + +sub to_bytes { + pack"a*", shift; +} + { use charnames ':full'; - print "not " unless "\N{CYRILLIC SMALL LETTER BE}" eq $encoded_be; + print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; print "ok 4\n"; use charnames qw(cyrillic greek :short); - print "not " unless "\N{be},\N{alpha},\N{hebrew:bet}" + print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") eq "$encoded_be,$encoded_alpha,$encoded_bet"; print "ok 5\n"; } @@ -72,3 +78,33 @@ $encoded_bet = "\327\221"; print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; print "ok 12\n"; } + +{ + use charnames qw(:full); + use utf8; + + my $x = "\x{221b}"; + my $named = "\N{CUBE ROOT}"; + + print "not " unless ord($x) == ord($named); + print "ok 13\n"; +} + +{ + use charnames qw(:full); + use utf8; + print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; + print "ok 14\n"; +} + +{ + use charnames ':full'; + +# XXX this test breaks in 5.6.x because the Unicode database is missing +# "DESERET SMALL LETTER ENG". Uncomment after updating to Unicode 3.1 +# print "not " +# unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; + print "ok 15\n"; + +} + diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t index 7603575..b5426ca 100755 --- a/contrib/perl5/t/lib/checktree.t +++ b/contrib/perl5/t/lib/checktree.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index a636ff0..334374d 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -9,12 +9,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Complex; -my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); +use vars qw($VERSION); + +$VERSION = 1.91; my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -27,7 +29,7 @@ my @script = ( my $eps = 1e-13; if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-11; # results in Cray UNICOS, and occasionally also + $eps = 1e-10; # results in Cray UNICOS, and occasionally also } # cos(), sin(), cosh(), sinh(). The division # of doubles is the current suspect. @@ -159,20 +161,18 @@ test_dbz( 'acsch(0)', 'asec(0)', 'asech(0)', - 'atan(-$i)', 'atan($i)', # 'atanh(-1)', # Log of zero. 'atanh(+1)', 'cot(0)', 'coth(0)', 'csc(0)', - 'tan($pip2)', 'csch(0)', - 'tan($pip2)', ); test_loz( 'log($zero)', + 'atan(-$i)', 'acot(-$i)', 'atanh(-1)', 'acoth(-1)', @@ -187,7 +187,7 @@ sub test_broot { eval 'root(2, $op)'; (\$bad) = (\$@ =~ /(.+)/); print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root must be/); + print 'not ' unless (\$@ =~ /root rank must be/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -196,6 +196,13 @@ EOT test_broot(qw(-3 -2.1 0 0.99)); sub test_display_format { + $test++; + push @script, <<EOS; + print "# package display_format cartesian?\n"; + print "not " unless Math::Complex->display_format eq 'cartesian'; + print "ok $test\n"; +EOS + push @script, <<EOS; my \$j = (root(1,3))[1]; @@ -204,7 +211,7 @@ EOS $test++; push @script, <<EOS; - print "# display_format polar?\n"; + print "# j display_format polar?\n"; print "not " unless \$j->display_format eq 'polar'; print "ok $test\n"; EOS @@ -264,7 +271,7 @@ EOS $test++; push @script, <<EOS; print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; print "ok $test\n"; \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); @@ -278,12 +285,20 @@ EOS \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); EOS + $test++; push @script, <<EOS; print "# j = \$j\n"; print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; print "ok $test\n"; EOS + + $test++; + push @script, <<EOS; + print "# j display_format cartesian?\n"; + print "not " unless \$j->display_format eq 'cartesian'; + print "ok $test\n"; +EOS } test_display_format(); @@ -894,7 +909,7 @@ __END__ ( 2,-3):( 1.96863792579310, -0.96465850440760) &acosh -(-2.0,0):( -1.31695789692482, 3.14159265358979) +(-2.0,0):( 1.31695789692482, 3.14159265358979) (-1.0,0):( 0, 3.14159265358979) (-0.5,0):( 0, 2.09439510239320) ( 0.0,0):( 0, 1.57079632679490) @@ -904,8 +919,8 @@ __END__ &acosh ( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( -1.98338702991653, -2.14144911111600) -(-2,-3):( -1.98338702991653, 2.14144911111600) +(-2, 3):( 1.98338702991653, 2.14144911111600) +(-2,-3):( 1.98338702991653, -2.14144911111600) ( 2,-3):( 1.98338702991654, -1.00014354247380) &atanh @@ -924,15 +939,15 @@ __END__ &asech (-2.0,0):( 0 , 2.09439510239320) (-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -1.31695789692482, 3.14159265358979) +(-0.5,0):( 1.31695789692482, 3.14159265358979) ( 0.5,0):( 1.31695789692482, 0 ) ( 1.0,0):( 0 , 0 ) ( 2.0,0):( 0 , 1.04719755119660) &asech ( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( -0.23133469857397, 1.72118193112276) -(-2,-3):( -0.23133469857397, -1.72118193112276) +(-2, 3):( 0.23133469857397, -1.72118193112276) +(-2,-3):( 0.23133469857397, 1.72118193112276) ( 2,-3):( 0.23133469857397, 1.42041072246703) &acsch diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t index b13e50ea..1822823 100755 --- a/contrib/perl5/t/lib/db-btree.t +++ b/contrib/perl5/t/lib/db-btree.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use warnings; +use strict; use DB_File; use Fcntl; -print "1..155\n"; +print "1..157\n"; sub ok { @@ -82,7 +84,9 @@ sub docat_del } -$db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); my $Dfile = "dbbtree.tmp"; unlink $Dfile; @@ -128,17 +132,19 @@ ok(16, $dbh->{prefix} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; -eval '$q = $dbh->{fred}' ; +eval 'my $q = $dbh->{fred}' ; ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE +my ($X, %h) ; ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -209,8 +215,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(27, $#keys == 29 && $#values == 29) ; @@ -235,12 +241,19 @@ ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; ok(31, $h{'foo'} eq '' ) ; -#$h{''} = 'bar'; -#ok(32, $h{''} eq 'bar' ); -ok(32,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(32, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(33, $ok); @@ -250,7 +263,7 @@ ok(33, $ok); ok(34, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(35, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -259,7 +272,7 @@ ok(35, join(':',200..400) eq join(':',@foo) ); # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(36, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -280,9 +293,12 @@ ok(40, $value eq 'value' ); $status = $X->del('q') ; ok(41, $status == 0 ); -#$status = $X->del('') ; -#ok(42, $status == 0 ); -ok(42,1) ; +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved ok(43, ! defined $h{'q'}) ; @@ -362,7 +378,7 @@ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) $status = $X->seq($key, $value, R_FIRST) ; ok(66, $status == 0 ); -$previous = $key ; +my $previous = $key ; $ok = 1 ; while (($status = $X->seq($key, $value, R_NEXT)) == 0) @@ -411,6 +427,7 @@ untie %h ; unlink $Dfile; # Now try an in memory file +my $Y; ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); # fd with an in memory file should return failure @@ -424,6 +441,7 @@ untie %h ; # Duplicate keys my $bt = new DB_File::BTREEINFO ; $bt->{flags} = R_DUP ; +my ($YY, %hh); ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; $hh{'Wall'} = 'Larry' ; @@ -469,34 +487,38 @@ unlink $Dfile; # test multiple callbacks -$Dfile1 = "btree1" ; -$Dfile2 = "btree2" ; -$Dfile3 = "btree3" ; +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; -$dbh1 = new DB_File::BTREEINFO ; -{ local $^W = 0 ; - $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; -$dbh2 = new DB_File::BTREEINFO ; +my $dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = new DB_File::BTREEINFO ; +my $dbh3 = new DB_File::BTREEINFO ; $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; -@Keys = qw( 0123 12 -1234 9 987654321 def ) ; -{ local $^W = 0 ; - @srt_1 = sort { $a <=> $b } @Keys ; } +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} @srt_2 = sort { $a cmp $b } @Keys ; @srt_3 = sort { length $a <=> length $b } @Keys ; foreach (@Keys) { - { local $^W = 0 ; - $h{$_} = 1 ; } + $h{$_} = 1 ; $g{$_} = 1 ; $k{$_} = 1 ; } @@ -566,6 +588,7 @@ unlink $Dfile1 ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -573,6 +596,7 @@ unlink $Dfile1 ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -656,6 +680,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -762,6 +787,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -824,6 +850,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -852,6 +879,7 @@ EOM # BTREE example 1 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -904,6 +932,7 @@ EOM # BTREE example 2 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -955,6 +984,7 @@ EOM # BTREE example 3 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1010,6 +1040,7 @@ EOM # BTREE example 4 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1058,6 +1089,7 @@ EOM # BTREE example 5 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1092,6 +1124,7 @@ EOM # BTREE example 6 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1126,6 +1159,7 @@ EOM # BTREE example 7 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; use Fcntl ; @@ -1217,4 +1251,46 @@ EOM # unlink $Dfile; #} +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(156, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(157, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t index c52d8ae..effc60b 100755 --- a/contrib/perl5/t/lib/db-hash.t +++ b/contrib/perl5/t/lib/db-hash.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use strict; +use warnings; use DB_File; use Fcntl; -print "1..109\n"; +print "1..111\n"; sub ok { @@ -57,6 +59,9 @@ sub docat_del } my $Dfile = "dbhash.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + unlink $Dfile; umask(0); @@ -98,13 +103,14 @@ ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); # Now check the interface to HASH - +my ($X, %h); ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -176,8 +182,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(23, $#keys == 29 && $#values == 29) ; @@ -197,14 +203,19 @@ ok(25, $#keys == 31) ; $h{'foo'} = ''; ok(26, $h{'foo'} eq '' ); -# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. -# This feature will be reenabled in a future version of Berkeley DB. -#$h{''} = 'bar'; -#ok(27, $h{''} eq 'bar' ); -ok(27,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(28, $ok ); @@ -214,7 +225,7 @@ ok(28, $ok ); ok(29, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(30, join(':',200..400) eq join(':',@foo) ); @@ -223,7 +234,7 @@ ok(30, join(':',200..400) eq join(':',@foo) ); # Check NOOVERWRITE will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(31, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -246,9 +257,10 @@ $status = $X->del('q') ; ok(36, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -$^W = 0 ; -ok(37, $h{'q'} eq undef ); -$^W = 1 ; +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} # Attempting to delete a non-existant key should fail @@ -361,6 +373,7 @@ untie %h ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -368,6 +381,7 @@ untie %h ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -451,6 +465,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -557,6 +572,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -619,6 +635,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -643,6 +660,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -682,4 +700,44 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(110, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(111, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index 276f38b..8b5a88c 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -12,6 +12,7 @@ BEGIN { use DB_File; use Fcntl; use strict ; +use warnings; use vars qw($dbh $Dfile $bad_ones $FA) ; # full tied array support started in Perl 5.004_57 @@ -99,7 +100,7 @@ sub bad_one EOM } -print "1..126\n"; +print "1..128\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -340,6 +341,7 @@ unlink $Dfile; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -347,6 +349,7 @@ unlink $Dfile; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -487,6 +490,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (@h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -593,6 +597,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (@h, $db) ; @@ -655,6 +660,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (@h, $db) ; unlink $Dfile; @@ -679,6 +685,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; @@ -734,6 +741,7 @@ EOM { my $redirect = new Redirect $save_output ; + use warnings FATAL => qw(all); use strict ; use vars qw(@h $H $file $i) ; use DB_File ; @@ -836,4 +844,46 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(127, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(128, $a eq "") ; + untie @h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t index a8683c7..aa7be35 100755 --- a/contrib/perl5/t/lib/dirhand.t +++ b/contrib/perl5/t/lib/dirhand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (not $Config{'d_readdir'}) { print "1..0\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t index ea537bf..fd9bb1d 100755 --- a/contrib/perl5/t/lib/dosglob.t +++ b/contrib/perl5/t/lib/dosglob.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..10\n"; @@ -39,7 +39,7 @@ while (defined($_ = <*/a*.t>)) { print "not " if @r != $r; print "ok 4\n"; -# check if array context works +# check if list context works @r = (); for (<*/a*.t>) { print "# $_\n"; diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t index 4d6f782..be711f1 100755 --- a/contrib/perl5/t/lib/dprof.t +++ b/contrib/perl5/t/lib/dprof.t @@ -2,23 +2,28 @@ BEGIN { chdir( 't' ) if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ + print "1..0 # Skip: Devel::DProf was not built\n"; + exit 0; + } } END { - unlink 'tmon.out', 'err'; + while(-e 'tmon.out' && unlink 'tmon.out') {} + while(-e 'err' && unlink 'err') {} } use Benchmark qw( timediff timestr ); use Getopt::Std 'getopts'; -use Config '%Config'; getopts('vI:p:'); # -v Verbose # -I Add to @INC # -p Name of perl binary -@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>; # glob-sort, for OS/2 +@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2 $path_sep = $Config{path_sep} || ':'; $perl5lib = $opt_I || join( $path_sep, @INC ); @@ -42,7 +47,7 @@ sub profile { my $opt_d = '-d:DProf'; my $t_start = new Benchmark; - open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n"; @results = <R>; close R; my $t_total = timediff( new Benchmark, $t_start ); @@ -52,15 +57,17 @@ sub profile { print @results } - print timestr( $t_total, 'nop' ), "\n"; + print '# ',timestr( $t_total, 'nop' ), "\n"; } sub verify { my $test = shift; - system $perl, '-I../lib', '-I./lib/dprof', $test, - $opt_v?'-v':'', '-p', $perl; + my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; + $command .= ' -v' if $opt_v; + $command .= ' -p '. $perl; + system $command; } @@ -68,6 +75,7 @@ $| = 1; print "1..18\n"; while( @tests ){ $test = shift @tests; + $test =~ s/\.$// if $^O eq 'VMS'; if( $test =~ /_t$/i ){ print "# $test" . '.' x (20 - length $test); profile $test; diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm index 7e34da5..152cddc 100644 --- a/contrib/perl5/t/lib/dprof/V.pm +++ b/contrib/perl5/t/lib/dprof/V.pm @@ -13,15 +13,19 @@ $num = 0; $results = $expected = ''; $perl = $opt_p || $^X; $dpp = $opt_d || '../utils/dprofpp'; +$dpp .= '.com' if $^O eq 'VMS'; print "\nperl: $perl\n" if $opt_v; if( ! -f $perl ){ die "Where's Perl?" } -if( ! -f $dpp ){ die "Where's dprofpp?" } +if( ! -f $dpp ) { + ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@; + die "Where's dprofpp?" if( ! -f $dpp ); +} sub dprofpp { my $switches = shift; - open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n"; + open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n"; @results = <D>; close D; diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t index 8c095e5..d4b3a92 100755 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 3167535..be9732f 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -5,7 +5,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; @@ -257,11 +262,14 @@ EOT ## $WANT = <<'EOT'; #$VAR1 = { -# "abc\0'\efg" => "mno\0" +# "abc\0'\efg" => "mno\0", +# "reftest" => \\1 #}; EOT -$foo = { "abc\000\'\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000", + "reftest" => \\1, + }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -269,7 +277,8 @@ $foo = { "abc\000\'\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\0\\'\efg' => 'mno\0' +# 'abc\0\\'\efg' => 'mno\0', +# 'reftest' => \\\\1 #}; EOT @@ -287,7 +296,7 @@ EOT package main; use Data::Dumper; $foo = 5; - @foo = (10,\*foo); + @foo = (-10,\*foo); %foo = (a=>1,b=>\$foo,c=>\@foo); $foo{d} = \%foo; $foo[2] = \%foo; @@ -299,7 +308,7 @@ EOT #*::foo = \5; #*::foo = [ # #0 -# 10, +# -10, # #1 # do{my $o}, # #2 @@ -330,7 +339,7 @@ EOT #$foo = \*::foo; #*::foo = \5; #*::foo = [ -# 10, +# -10, # do{my $o}, # { # 'a' => 1, @@ -356,7 +365,7 @@ EOT ## $WANT = <<'EOT'; #@bar = ( -# 10, +# -10, # \*::foo, # {} #); @@ -383,7 +392,7 @@ EOT ## $WANT = <<'EOT'; #$bar = [ -# 10, +# -10, # \*::foo, # {} #]; @@ -411,7 +420,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #@bar = ( -# 10, +# -10, # $foo, # { # a => 1, @@ -433,7 +442,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #$bar = [ -# 10, +# -10, # $foo, # { # a => 1, diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t index dba68db..0cbbdbf 100755 --- a/contrib/perl5/t/lib/english.t +++ b/contrib/perl5/t/lib/english.t @@ -2,7 +2,7 @@ print "1..16\n"; -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } use English; use Config; my $threads = $Config{'use5005threads'} || 0; @@ -43,5 +43,5 @@ print $GID == $( ? "ok 12\n" : "not ok 12\n"; print $EUID == $> ? "ok 13\n" : "not ok 13\n"; print $EGID == $) ? "ok 14\n" : "not ok 14\n"; -print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n"; +print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t index d90d892..c5068fd 100755 --- a/contrib/perl5/t/lib/env-array.t +++ b/contrib/perl5/t/lib/env-array.t @@ -4,7 +4,7 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ($^O eq 'VMS') { diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t index 2573164..ff6af2e 100755 --- a/contrib/perl5/t/lib/env.t +++ b/contrib/perl5/t/lib/env.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } BEGIN { diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t index 6320f6b..02f5ce2 100755 --- a/contrib/perl5/t/lib/errno.t +++ b/contrib/perl5/t/lib/errno.t @@ -3,7 +3,11 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '../lib'; + } } } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t index 4013fbd..f00b876 100755 --- a/contrib/perl5/t/lib/fatal.t +++ b/contrib/perl5/t/lib/fatal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; print "1..15\n"; } diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t index 7709ee5..a3f591a 100755 --- a/contrib/perl5/t/lib/fields.t +++ b/contrib/perl5/t/lib/fields.t @@ -4,7 +4,7 @@ my $w; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { if ($_[0] =~ /^Hides field 'b1' in base class/) { $w++; diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t index 019f374..a97fdd5 100755 --- a/contrib/perl5/t/lib/filecache.t +++ b/contrib/perl5/t/lib/filecache.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t index b6fcbea..3072c54 100755 --- a/contrib/perl5/t/lib/filecopy.t +++ b/contrib/perl5/t/lib/filecopy.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } $| = 1; diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t index e9a2916..362c1eb 100755 --- a/contrib/perl5/t/lib/filefind.t +++ b/contrib/perl5/t/lib/filefind.t @@ -6,7 +6,7 @@ my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ( $symlink_exists ) { print "1..117\n"; } @@ -19,6 +19,7 @@ finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); my $case = 2; +my $FastFileTests_OK = 0; END { unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', @@ -57,8 +58,15 @@ sub wanted { print "# '$_' => 1\n"; s#\.$## if ($^O eq 'VMS' && $_ ne '.'); Check( $Expect{$_} ); - delete $Expect{$_}; + if ( $FastFileTests_OK ) { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d _ ); + } else { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d $_ ); + } $File::Find::prune=1 if $_ eq 'faba'; + } sub dn_wanted { @@ -106,6 +114,9 @@ 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; +%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, + 'fb' => 1, 'fba' => 1); +delete @Expect_Dir{'fb','fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, },'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -113,6 +124,9 @@ Check( scalar(keys %Expect) == 0 ); '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; +%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); +delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -122,6 +136,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&dn_wanted },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -130,13 +147,19 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); Check( scalar(keys %Expect) == 0 ); if ( $symlink_exists ) { + $FastFileTests_OK= 1; %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); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -145,6 +168,8 @@ if ( $symlink_exists ) { '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); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -152,6 +177,8 @@ if ( $symlink_exists ) { '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); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -160,6 +187,8 @@ if ( $symlink_exists ) { '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); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t index 46a1e35..9268122 100755 --- a/contrib/perl5/t/lib/filefunc.t +++ b/contrib/perl5/t/lib/filefunc.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t index 22cff0e..0f3e177 100755 --- a/contrib/perl5/t/lib/filehand.t +++ b/contrib/perl5/t/lib/filehand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; @@ -20,7 +20,7 @@ $| = 1; autoflush $mystdout; print "1..11\n"; -print $mystdout "ok ",fileno($mystdout),"\n"; +print $mystdout "ok ".fileno($mystdout)."\n"; $fh = (new FileHandle "./TEST", O_RDONLY or new FileHandle "TEST", O_RDONLY) diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t index 5628d0c..42e0ae9 100755 --- a/contrib/perl5/t/lib/filepath.t +++ b/contrib/perl5/t/lib/filepath.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t index da52ec5..c6d155f 100755 --- a/contrib/perl5/t/lib/filespec.t +++ b/contrib/perl5/t/lib/filespec.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Each element in this array is a single test. Storing them this way makes diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t index f0939e9..3e742f9 100755 --- a/contrib/perl5/t/lib/findbin.t +++ b/contrib/perl5/t/lib/findbin.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t index dc4e96e..ecbd662 100755 --- a/contrib/perl5/t/lib/gdbm.t +++ b/contrib/perl5/t/lib/gdbm.t @@ -3,7 +3,7 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bGDBM_File\b/) { print "1..0 # Skip: GDBM_File was not built\n"; @@ -11,16 +11,21 @@ BEGIN { } } +use strict; +use warnings; + + use GDBM_File; -print "1..66\n"; +print "1..68\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h ; +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -28,11 +33,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -57,7 +63,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -82,12 +88,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -103,17 +109,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -137,6 +143,7 @@ sub ok package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -178,6 +185,7 @@ EOM close FILE ; BEGIN { push @INC, '.'; } + unlink <dbhash.tmp*> ; eval 'use SubDB ; '; main::ok(13, $@ eq "") ; @@ -210,6 +218,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -316,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -360,7 +370,7 @@ EOM ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -378,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -392,3 +403,24 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use GDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); + $h{ABC} = undef; + ok(68, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t index 0354627..fb70f10 100755 --- a/contrib/perl5/t/lib/getopt.t +++ b/contrib/perl5/t/lib/getopt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t index 4728083..a014bfd 100755 --- a/contrib/perl5/t/lib/glob-basic.t +++ b/contrib/perl5/t/lib/glob-basic.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -26,8 +31,8 @@ sub array { $ENV{PATH} = "/bin"; delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; @correct = (); -if (opendir(D, ".")) { - @correct = grep { !/^\.\.?$/ } sort readdir(D); +if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { + @correct = grep { !/^\./ } sort readdir(D); closedir D; } @a = File::Glob::glob("*", 0); @@ -39,12 +44,12 @@ print "ok 2\n"; # look up the user's home directory # should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' || $^O ne 'VMS') { +if ($^O ne 'MSWin32' && $^O ne 'VMS') { eval { ($name, $home) = (getpwuid($>))[0,7]; 1; } and do { - @a = File::Glob::glob("~$name", GLOB_TILDE); + @a = bsd_glob("~$name", GLOB_TILDE); if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { print "not "; } @@ -54,7 +59,7 @@ print "ok 3\n"; # check backslashing # should return a list with one item, and not set ERROR -@a = File::Glob::glob('TEST', GLOB_QUOTE); +@a = bsd_glob('TEST', GLOB_QUOTE); if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { local $/ = "]["; print "# [@a]\n"; @@ -65,7 +70,7 @@ print "ok 4\n"; # check nonexistent checks # should return an empty list # XXX since errfunc is NULL on win32, this test is not valid there -@a = File::Glob::glob("asdfasdf", 0); +@a = bsd_glob("asdfasdf", 0); if ($^O ne 'MSWin32' and scalar @a != 0) { print "# |@a|\nnot "; } @@ -81,7 +86,7 @@ if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' else { $dir = "PtEeRsLt.dir"; mkdir $dir, 0; - @a = File::Glob::glob("$dir/*", GLOB_ERR); + @a = bsd_glob("$dir/*", GLOB_ERR); #print "\@a = ", array(@a); rmdir $dir; if (scalar(@a) != 0 || GLOB_ERROR == 0) { @@ -91,16 +96,21 @@ else { } # check for csh style globbing -@a = File::Glob::glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { print "not "; } print "ok 7\n"; -@a = File::Glob::glob( +@a = bsd_glob( '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC + GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) ); + +# Working on t/TEST often causes this test to fail because it sees temp +# and RCS files. Filter them out, and .pm files too. +@a = grep !/(,v$|~$|\.pm$)/, @a; + unless (@a == 3 and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') and $a[1] eq 'a' @@ -112,8 +122,8 @@ print "ok 8\n"; # "~" should expand to $ENV{HOME} $ENV{HOME} = "sweet home"; -@a = File::Glob::glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless (@a == 1 and $a[0] eq $ENV{HOME}) { +@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { print "not "; } print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t index 32719b2..881470c 100755 --- a/contrib/perl5/t/lib/glob-case.t +++ b/contrib/perl5/t/lib/glob-case.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -17,20 +22,22 @@ use File::Glob qw(:glob csh_glob); $loaded = 1; print "ok 1\n"; +my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; + # 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 +@a = csh_glob($pat); # 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 +@a = csh_glob($pat); # 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); +@a = bsd_glob($pat, GLOB_NOCASE); print "not " unless @a >= 3; print "ok 4\n"; @@ -47,7 +54,7 @@ else { rmdir "[]"; print "# returned @a\nnot " unless @a == 1; print "ok 6\n"; - @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + @a = bsd_glob("lib\\*", GLOB_QUOTE); print "not " if @a == 0; print "ok 7\n"; } diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t index 9d273bd..1d79032 100755 --- a/contrib/perl5/t/lib/glob-global.t +++ b/contrib/perl5/t/lib/glob-global.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -31,9 +36,9 @@ use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; -$_ = "lib/*.t"; +$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; my @r = glob; -print "not " if $_ ne 'lib/*.t'; +print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); print "ok 2\n"; # we should have at least basic.t, global.t, taint.t @@ -41,7 +46,11 @@ print "# |@r|\nnot " if @r < 3; print "ok 3\n"; # check if <*/*> works -@r = <*/*.t>; +if ($^O eq "MacOS") { + @r = <:*:*.t>; +} else { + @r = <*/*.t>; +} # at least t/global.t t/basic.t, t/taint.t print "not " if @r < 3; print "ok 4\n"; @@ -49,34 +58,55 @@ my $r = scalar @r; # check if scalar context works @r = (); -while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (defined($_ = <:*:*.t>)) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (defined($_ = <*/*.t>)) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 5\n"; -# check if array context works +# check if list context works @r = (); -for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + for (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + for (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 6\n"; # test if implicit assign to $_ in while() works @r = (); -while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 7\n"; # test if explicit glob() gets assign magic too my @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -87,7 +117,7 @@ print "ok 8\n"; package Foo; use File::Glob ':globally'; @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -97,14 +127,26 @@ print "ok 9\n"; # test if different glob ops maintain independent contexts @s = (); my $i = 0; -while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_ <"; + push @s, $_; + while (<:bas*:*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; + } +} else { + while (<*/*.t>) { + #print "# $_ <"; + push @s, $_; + while (<bas*/*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; } - #print " >\n"; } print "not " if "@r" ne "@s" or not $i; print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t index a8dc213..4c09903 100755 --- a/contrib/perl5/t/lib/glob-taint.t +++ b/contrib/perl5/t/lib/glob-taint.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -18,7 +23,7 @@ $loaded = 1; print "ok 1\n"; # all filenames should be tainted -@a = File::Glob::glob("*"); +@a = File::Glob::bsd_glob("*"); eval { $a = join("",@a), kill 0; 1 }; unless ($@ =~ /Insecure dependency/) { print "not "; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t index 4b25322..c5d857d 100755 --- a/contrib/perl5/t/lib/gol-basic.t +++ b/contrib/perl5/t/lib/gol-basic.t @@ -1,16 +1,18 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -use Getopt::Long 2.17; +use Getopt::Long qw(:config no_ignore_case); +die("Getopt::Long version 2.24 required--this is only version ". + $Getopt::Long::VERSION) + unless $Getopt::Long::VERSION >= 2.24; print "1..9\n"; @ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); undef $opt_baR; undef $opt_bar; print "ok 1\n" if GetOptions ("foo", "Foo=s"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t index a4f807c..0bbe386 100755 --- a/contrib/perl5/t/lib/gol-compat.t +++ b/contrib/perl5/t/lib/gol-compat.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } require "newgetopt.pl"; diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t index a1b2c05..3bd81a3 100755 --- a/contrib/perl5/t/lib/gol-linkage.t +++ b/contrib/perl5/t/lib/gol-linkage.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } use Getopt::Long; diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t index acb150d..15dc2b5 100755 --- a/contrib/perl5/t/lib/h2ph.t +++ b/contrib/perl5/t/lib/h2ph.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..2\n"; diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t index 6f61fb9..85a04cd 100755 --- a/contrib/perl5/t/lib/hostname.t +++ b/contrib/perl5/t/lib/hostname.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { + print "1..0 # Skip: Sys::Hostname was not built\n"; + exit 0; + } } use Sys::Hostname; diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t index 48cb6b5..db1a322 100755 --- a/contrib/perl5/t/lib/io_const.t +++ b/contrib/perl5/t/lib/io_const.t @@ -2,7 +2,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t index 11ec8bc..3689871 100755 --- a/contrib/perl5/t/lib/io_dir.t +++ b/contrib/perl5/t/lib/io_dir.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } require Config; import Config; if ($] < 5.00326 || not $Config{'d_readdir'}) { diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t index c895fb4..0f17264 100755 --- a/contrib/perl5/t/lib/io_dup.t +++ b/contrib/perl5/t/lib/io_dup.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t index 3503215..cf55c98 100755 --- a/contrib/perl5/t/lib/io_linenum.t +++ b/contrib/perl5/t/lib/io_linenum.t @@ -13,7 +13,7 @@ BEGIN chdir 't'; $File =~ s/^t\W+//; # Remove first directory } - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require strict; import strict; } diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t index 7337a5f..55030b5 100755 --- a/contrib/perl5/t/lib/io_multihomed.t +++ b/contrib/perl5/t/lib/io_multihomed.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t index bcb89a0..ae18224 100755 --- a/contrib/perl5/t/lib/io_pipe.t +++ b/contrib/perl5/t/lib/io_pipe.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t index 68ad7b7..d391566 100755 --- a/contrib/perl5/t/lib/io_poll.t +++ b/contrib/perl5/t/lib/io_poll.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -15,7 +15,7 @@ if ($^O eq 'mpeix') { select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..8\n"; +print "1..9\n"; use IO::Handle; use IO::Poll qw(/POLL/); @@ -75,3 +75,8 @@ $poll->poll(0.1); print "not " if $poll->events($stdout); print "ok 8\n"; + +$poll->remove($dupout); +print "not " + if $poll->handles; +print "ok 9\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t index 85e14ab..5d1dce3 100755 --- a/contrib/perl5/t/lib/io_sel.t +++ b/contrib/perl5/t/lib/io_sel.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t index 056d131f..45c16c2 100755 --- a/contrib/perl5/t/lib/io_sock.t +++ b/contrib/perl5/t/lib/io_sock.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -70,17 +70,15 @@ if($pid = fork()) { } elsif(defined $pid) { - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', PeerAddr => 'localhost' ) - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => '127.0.0.1' + ) + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; $sock->autoflush(1); @@ -114,7 +112,8 @@ if($pid = fork()) { $listen->close; } elsif (defined $pid) { # child, try various ways to connect - $sock = IO::Socket::INET->new("localhost:$port"); + $sock = IO::Socket::INET->new("localhost:$port") + || IO::Socket::INET->new("127.0.0.1:$port"); if ($sock) { print "not " unless $sock->connected; print "ok 6\n"; @@ -151,7 +150,9 @@ if($pid = fork()) { sleep(1); $sock = IO::Socket->new(Domain => AF_INET, - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket->new(Domain => AF_INET, + PeerAddr => "127.0.0.1:$port"); if ($sock) { $sock->print("ok 11\n"); $sock->print("quit\n"); @@ -166,7 +167,10 @@ if($pid = fork()) { # Then test UDP sockets $server = IO::Socket->new(Domain => AF_INET, Proto => 'udp', - LocalAddr => 'localhost'); + LocalAddr => 'localhost') + || IO::Socket->new(Domain => AF_INET, + Proto => 'udp', + LocalAddr => '127.0.0.1'); $port = $server->sockport; if ($^O eq 'mpeix') { @@ -179,7 +183,9 @@ if ($^O eq 'mpeix') { } elsif (defined($pid)) { #child $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket::INET->new(Proto => 'udp', + PeerAddr => "127.0.0.1:$port"); $sock->send("ok 12\n"); sleep(1); $sock->send("ok 12\n"); # send another one to be sure diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t index deaa6c7..19afa2f 100755 --- a/contrib/perl5/t/lib/io_taint.t +++ b/contrib/perl5/t/lib/io_taint.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t index 8d75242..3aa4b03 100755 --- a/contrib/perl5/t/lib/io_tell.t +++ b/contrib/perl5/t/lib/io_tell.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $tell_file = "TEST"; } else { diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index 3d5145e..d63a5dc 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -57,19 +57,15 @@ print "1..7\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 1\n"; $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 2\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t index 247647a..2f6def0 100755 --- a/contrib/perl5/t/lib/io_unix.t +++ b/contrib/perl5/t/lib/io_unix.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t index 6bbba16..2449fc4 100755 --- a/contrib/perl5/t/lib/io_xs.t +++ b/contrib/perl5/t/lib/io_xs.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -40,3 +40,4 @@ print scalar <$x>; $! = 0; $x->setpos(undef); print $! ? "ok 4 # $!\n" : "not ok 4\n"; + diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t index a4f3e3f..795ad5d 100755 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -3,13 +3,15 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; my $reason; - if ($Config{'d_sem'} ne 'define') { + if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { + $reason = 'IPC::SysV was not built'; + } elsif ($Config{'d_sem'} ne 'define') { $reason = '$Config{d_sem} undefined'; } elsif ($Config{'d_msg'} ne 'define') { $reason = '$Config{d_msg} undefined'; diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t index 39c3f40..e56fcd9 100755 --- a/contrib/perl5/t/lib/ndbm.t +++ b/contrib/perl5/t/lib/ndbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { print "1..0 # Skip: NDBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require NDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..65\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,NDBM_File,'Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -315,6 +323,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -359,7 +368,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -377,6 +386,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -391,3 +401,20 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use NDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t index f8b8a11..b935d04 100755 --- a/contrib/perl5/t/lib/odbm.t +++ b/contrib/perl5/t/lib/odbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bODBM_File\b/) { print "1..0 # Skip: ODBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require ODBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..66\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -317,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -361,7 +370,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -379,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -394,6 +404,27 @@ EOM unlink <Op.dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use ODBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(66, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} + if ($^O eq 'hpux') { print <<EOM; # diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t index f83a689..a785fce 100755 --- a/contrib/perl5/t/lib/opcode.t +++ b/contrib/perl5/t/lib/opcode.t @@ -4,7 +4,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t index 6443112..85b807c 100755 --- a/contrib/perl5/t/lib/open2.t +++ b/contrib/perl5/t/lib/open2.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t index 7cd0ca3..a0da34f 100755 --- a/contrib/perl5/t/lib/open3.t +++ b/contrib/perl5/t/lib/open3.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) @@ -20,7 +20,7 @@ use IO::Handle; use IPC::Open3; #require 'open3.pl'; use subs 'open3'; -my $perl = './perl'; +my $perl = $^X; sub ok { my ($n, $result, $info) = @_; diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t index ce8b6d0..56b1bac 100755 --- a/contrib/perl5/t/lib/ops.t +++ b/contrib/perl5/t/lib/ops.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 2c936f1..261d81f 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t index dd24c79..de27dee 100755 --- a/contrib/perl5/t/lib/ph.t +++ b/contrib/perl5/t/lib/ph.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # All the constants which Socket.pm tries to make available: diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index abc4563..994704a 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { print "1..0\n"; @@ -17,6 +17,7 @@ $| = 1; print "1..27\n"; $Is_W32 = $^O eq 'MSWin32'; +$Is_Dos = $^O eq 'dos'; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -24,6 +25,11 @@ print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; write(1,"ok 3\nnot ok 3\n", 5); +if ($Is_Dos) { + for (4..5) { + print "ok $_ # skipped, no pipe() support on dos\n"; + } +} else { @fds = POSIX::pipe(); print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; CORE::open($reader = \*READER, "<&=".$fds[0]); @@ -32,10 +38,11 @@ print $writer "ok 5\n"; close $writer; print <$reader>; close $reader; +} -if ($Is_W32) { +if ($Is_W32 || $Is_Dos) { for (6..11) { - print "ok $_ # skipped, no sigaction support on win32\n"; + print "ok $_ # skipped, no sigaction support on win32/dos\n"; } } else { diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t index 6e12873..27993d9 100755 --- a/contrib/perl5/t/lib/safe1.t +++ b/contrib/perl5/t/lib/safe1.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index 293b515..4d6c84a 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t index 2689d19..3221ca4 100755 --- a/contrib/perl5/t/lib/sdbm.t +++ b/contrib/perl5/t/lib/sdbm.t @@ -4,26 +4,39 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ print "1..0\n"; exit 0; } } + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require SDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..66\n"; +print "1..68\n"; unlink <Op_dbmx.*>; umask(0); -print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) - ? "ok 1\n" : "not ok 1\n"); +my %h ; +ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); -$Dfile = "Op_dbmx.pag"; +my $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx.*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,38 +120,30 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -145,6 +151,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw( @ISA @EXPORT) ; require Exporter ; @@ -213,6 +220,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -319,6 +327,7 @@ unlink <Op_dbmx*>, $Dfile; # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -363,7 +372,7 @@ unlink <Op_dbmx*>, $Dfile; ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -381,6 +390,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -396,3 +406,24 @@ unlink <Op_dbmx*>, $Dfile; unlink <Op_dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use SDBM_File ; + + unlink <Op_dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(68, $a eq "") ; + + untie %h; + unlink <Op_dbmx*>; +} diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index 46cea39..c36fdb8 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..4\n"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t index 677caec..3b58d70 100755 --- a/contrib/perl5/t/lib/selectsaver.t +++ b/contrib/perl5/t/lib/selectsaver.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t index d5e1848..481fd8f 100755 --- a/contrib/perl5/t/lib/socket.t +++ b/contrib/perl5/t/lib/socket.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && !(($^O eq 'VMS') && $Config{d_socket})) { @@ -21,8 +21,8 @@ if (socket(T,PF_INET,SOCK_STREAM,6)) { if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ print "ok 2\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; syswrite(T,"hello",5); $read = sysread(T,$buff,10); # Connection may be granted, then closed! @@ -51,8 +51,8 @@ if( socket(S,PF_INET,SOCK_STREAM,6) ){ if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ print "ok 5\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; syswrite(S,"olleh",5); $read = sysread(S,$buff,10); # Connection may be granted, then closed! diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t index a04cccd..d35f264 100755 --- a/contrib/perl5/t/lib/soundex.t +++ b/contrib/perl5/t/lib/soundex.t @@ -18,7 +18,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Soundex; diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t index 14c919c..03449a3 100755 --- a/contrib/perl5/t/lib/symbol.t +++ b/contrib/perl5/t/lib/symbol.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t index 2857120..2bdb69d 100755 --- a/contrib/perl5/t/lib/syslfs.t +++ b/contrib/perl5/t/lib/syslfs.t @@ -4,16 +4,21 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; # Don't bother if there are no quad offsets. if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -26,35 +31,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + print <<EOM; # -# If the lfs (large file support: large meaning larger than two gigabytes) -# tests are skipped or fail, it may mean either that your process -# (or process group) is not allowed to write large files (resource -# limits) or that the file system you are running the tests on doesn't -# let your user/group have large files (quota) or the filesystem simply -# doesn't support large files. You may even need to reconfigure your kernel. -# (This is all very operating system and site-dependent.) +# If the lfs (large file support: large meaning larger than two +# gigabytes) tests are skipped or fail, it may mean either that your +# process (or process group) is not allowed to write large files +# (resource limits) or that the file system (the network filesystem?) +# you are running the tests on doesn't let your user/group have large +# files (quota) or the filesystem simply doesn't support large files. +# You may even need to reconfigure your kernel. (This is all very +# operating system and site-dependent.) # # Perl may still be able to support large files, once you have # such a process, enough quota, and such a (file) system. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } print "# checking whether we have sparse files...\n"; # Known have-nots. -if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^O\n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -95,7 +107,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -103,16 +115,25 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-I../lib', '-e', <<'EOF'; +use Fcntl qw(/^O_/ /^SEEK_/); +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +my $syswrite = syswrite(BIG, "big"); +exit 0; +EOF + sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or do { warn "sysopen 'big' failed: $!\n"; bye }; my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (defined $sysseek && $sysseek == 5_000_000_000) { - print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", - defined $sysseek ? $sysseek : 'undef', ")\n"; - explain(); +unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { + $sysseek = 'undef' unless defined $sysseek; + explain("seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); bye(); } @@ -125,11 +146,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -138,8 +160,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -148,9 +169,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -166,28 +208,28 @@ print "ok 4\n"; sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye }; -fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000; +offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000); print "ok 5\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 6\n"; -fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001); print "ok 7\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001); print "ok 8\n"; -fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000); print "ok 9\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 10\n"; -fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000; +offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000); print "ok 11\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000); print "ok 12\n"; my $big; @@ -199,7 +241,9 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 -fail unless seek(BIG, 705_032_704, SEEK_SET); +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. +fail unless sysseek(BIG, 705_032_704, SEEK_SET); print "ok 15\n"; my $zero; @@ -210,7 +254,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t index daeee23..5ff3850 100755 --- a/contrib/perl5/t/lib/textfill.t +++ b/contrib/perl5/t/lib/textfill.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Wrap qw(&fill); diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t index 80395f4..c6ca123 100755 --- a/contrib/perl5/t/lib/texttabs.t +++ b/contrib/perl5/t/lib/texttabs.t @@ -1,28 +1,139 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..3\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST 1 u + x +END + x +END +TEST 2 e + x +END + x +END +TEST 3 e + x + y + z +END + x + y + z +END +TEST 4 u + x + y + z +END + x + y + z +END +TEST 5 u +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 6 e +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 7 u + x +END + x +END +TEST 8 e + + + -use Text::Tabs; + +END + + + + + +END +TEST 9 u + +END + +END +TEST 10 u + + + + + +END + + + + + +END +TEST 11 u +foobar IN A 140.174.82.12 + +END +foobar IN A 140.174.82.12 -$tabstop = 4; +END +DONE -$s1 = "foo\tbar\tb\tb"; -$s2 = expand $s1; -$s3 = unexpand $s2; +$| = 1; -print "not " unless $s2 eq "foo bar b b"; -print "ok 1\n"; +print "1..".scalar(@tests/2)."\n"; -print "not " unless $s3 eq "foo bar b\tb"; -print "ok 2\n"; +use Text::Tabs; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; -$tabstop = 8; + if ($2 eq 'e') { + $f = \&expand; + $fn = 'expand'; + } else { + $f = \&unexpand; + $fn = 'unexpand'; + } -print "not " unless unexpand(" foo") eq "\t\t foo"; -print "ok 3\n"; + my $back = &$f($in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\$\n------------ $fn -----------\n"; + print $back; + print "\$\n------------ expected ---------\n"; + print $out; + print "\$\n-------------------------------\n"; + $Text::Tabs::debug = 1; + my $back = &$f($in); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index bb1d5ca..fee6ce0 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -use Text::Wrap qw(&wrap); @tests = (split(/\nEND\n/s, <<DONE)); TEST1 @@ -84,21 +83,57 @@ END a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 4567 END +TEST10 +my mother once said +"never eat paste my darling" +would that I heeded +END + my mother once said + "never eat paste my darling" + would that I heeded +END +TEST11 +This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn +END + This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr + ogram_does_not_crash_and_burn +END +TEST12 +This + +Has + +Blank + +Lines + +END + This + + Has + + Blank + + Lines + +END DONE $| = 1; -print "1..", @tests/2, "\n"; +print "1..", 1 +@tests, "\n"; use Text::Wrap; $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; $tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); + +@st = @tests; +while (@st) { + my $in = shift(@st); + my $out = shift(@st); $in =~ s/^TEST(\d+)?\n//; @@ -126,4 +161,49 @@ while (@tests) { print "not ok $tn\n"; } $tn++; + +} + +@st = @tests; +while(@st) { + my $in = shift(@st); + my $out = shift(@st); + + $in =~ s/^TEST(\d+)?\n//; + + my @in = split("\n", $in, -1); + @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); + + my $back = wrap(' ', ' ', @in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input2 ------------\n"; + print $in; + print "\n------------ output2 -----------\n"; + print $back; + print "\n------------ expected2 ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; } + +$Text::Wrap::huge = 'overflow'; + +my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; +my $w = wrap('zzz','yyy',$tw); +print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); +$tn++; + diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t index 6b3c800..680e1af 100755 --- a/contrib/perl5/t/lib/thr5005.t +++ b/contrib/perl5/t/lib/thr5005.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (! $Config{'use5005threads'}) { print "1..0 # Skip: not use5005threads\n"; @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..21\n"; +print "1..22\n"; use Thread 'yield'; print "ok 1\n"; @@ -89,6 +89,18 @@ my $long = "This is short."; my $longe = " short."; my $thr1 = new Thread \&threaded, $short, $shorte, "19"; my $thr2 = new Thread \&threaded, $long, $longe, "20"; +my $thr3 = new Thread \&testsprintf, "21"; + +sub testsprintf { + my $testno = shift; + # this may coredump if thread vars are not properly initialised + my $same = sprintf "%.0f", $testno; + if ($testno eq $same) { + print "ok $testno\n"; + } else { + print "not ok $testno\t# '$testno' ne '$same'\n"; + } +} sub threaded { my ($string, $string_end, $testno) = @_; @@ -115,4 +127,5 @@ EOT } $thr1->join; $thr2->join; -print "ok 21\n"; +$thr3->join; +print "ok 22\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t index 23a0a94..b19aa0d 100755 --- a/contrib/perl5/t/lib/tie-push.t +++ b/contrib/perl5/t/lib/tie-push.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } { diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t index 5a678a5..c4ae071 100755 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t index cf3a183..f03f5d9 100755 --- a/contrib/perl5/t/lib/tie-stdhandle.t +++ b/contrib/perl5/t/lib/tie-stdhandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Tie::Handle; @@ -10,16 +10,16 @@ tie *tst,Tie::StdHandle; $f = 'tst'; -print "1..13\n"; +print "1..13\n"; # my $file tests -unlink("afile.new") if -f "afile"; -print "$!\nnot " unless open($f,"+>afile"); +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); print "ok 1\n"; print "$!\nnot " unless binmode($f); print "ok 2\n"; -print "not " unless -f "afile"; +print "not " unless -f "afile"; print "ok 3\n"; print "not " unless print $f "SomeData\n"; print "ok 4\n"; @@ -44,4 +44,4 @@ print "not " unless eof($f); print "ok 12\n"; print "not " unless close($f); print "ok 13\n"; -unlink("afile"); +unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t index 35ae1b8..31af30c 100755 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t index 359d71e..100e076 100755 --- a/contrib/perl5/t/lib/timelocal.t +++ b/contrib/perl5/t/lib/timelocal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Time::Local; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t index 20669f0..6949622 100755 --- a/contrib/perl5/t/lib/trig.t +++ b/contrib/perl5/t/lib/trig.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Trig; @@ -26,10 +26,11 @@ if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. } sub near ($$;$) { - abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); + my $e = defined $_[2] ? $_[2] : $eps; + $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; } -print "1..20\n"; +print "1..23\n"; $x = 0.9; print 'not ' unless (near(tan($x), sin($x) / cos($x))); @@ -137,24 +138,42 @@ use Math::Trig ':radial'; } { - use Math::Trig 'great_circle_distance'; + use Math::Trig 'great_circle_distance'; - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); + print "ok 18\n"; - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, pi, pi), pi)); + print "ok 19\n"; - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); + # London to Tokyo. + my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); + my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - my $km = great_circle_distance(@L, @T, 6378); + my $km = great_circle_distance(@L, @T, 6378); - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; + print 'not ' unless (near($km, 9605.26637021388)); + print "ok 20\n"; +} + +{ + my $R2D = 57.295779513082320876798154814169; + + sub frac { $_[0] - int($_[0]) } + + my $lotta_radians = deg2rad(1E+20, 1); + print "not " unless near($lotta_radians, 1E+20/$R2D); + print "ok 21\n"; + + my $negat_degrees = rad2deg(-1E20, 1); + print "not " unless near($negat_degrees, -1E+20*$R2D); + print "ok 22\n"; + + my $posit_degrees = rad2deg(-10000, 1); + print "not " unless near($posit_degrees, -10000*$R2D); + print "ok 23\n"; } # eof diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t index 60f72c3..88fbc55 100755 --- a/contrib/perl5/t/op/64bitint.t +++ b/contrib/perl5/t/op/64bitint.t @@ -3,20 +3,20 @@ BEGIN { eval { my $q = pack "q", 0 }; if ($@) { - print "1..0\n# no 64-bit types\n"; + print "1..0\n# Skip: no 64-bit types\n"; exit(0); } chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -# This could use a lot of more tests. +# This could use many more tests. # so that using > 0xfffffff constants and # 32+ bit integers don't cause noise no warnings qw(overflow portable); -print "1..48\n"; +print "1..55\n"; my $q = 12345678901; my $r = 23456789012; @@ -123,85 +123,106 @@ $x = $q - $r; print "not " unless $x == -11111110111 && -$x > $f; print "ok 22\n"; -$x = $q * 1234567; -print "not " unless $x == 15241567763770867 && $x > $f; -print "ok 23\n"; - -$x /= 1234567; -print "not " unless $x == $q && $x > $f; -print "ok 24\n"; - -$x = 98765432109 % 12345678901; -print "not " unless $x == 901; -print "ok 25\n"; - -# The following 12 tests adapted from op/inc. - -$a = 9223372036854775807; -$c = $a++; -print "not " unless $a == 9223372036854775808; -print "ok 26\n"; - -$a = 9223372036854775807; -$c = ++$a; -print "not " unless $a == 9223372036854775808 && $c == $a; -print "ok 27\n"; - -$a = 9223372036854775807; -$c = $a + 1; -print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; -print "ok 28\n"; - -$a = -9223372036854775808; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 29\n"; - -$a = -9223372036854775808; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 30\n"; - -$a = -9223372036854775808; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 31\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 32\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 33\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 34\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = $b--; -print "not " unless $b == -$a-1 && $c == -$a; -print "ok 35\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = --$b; -print "not " unless $b == -$a-1 && $c == $b; -print "ok 36\n"; - -$a = 9223372036854775808; -$b = -$a; -$b = $b - 1; -print "not " unless $b == -(++$a); -print "ok 37\n"; +if ($^O ne 'unicos') { + $x = $q * 1234567; + print "not " unless $x == 15241567763770867 && $x > $f; + print "ok 23\n"; + + $x /= 1234567; + print "not " unless $x == $q && $x > $f; + print "ok 24\n"; + + $x = 98765432109 % 12345678901; + print "not " unless $x == 901; + print "ok 25\n"; + + # The following 12 tests adapted from op/inc. + + $a = 9223372036854775807; + $c = $a++; + print "not " unless $a == 9223372036854775808; + print "ok 26\n"; + + $a = 9223372036854775807; + $c = ++$a; + print "not " + unless $a == 9223372036854775808 && $c == $a; + print "ok 27\n"; + + $a = 9223372036854775807; + $c = $a + 1; + print "not " + unless $a == 9223372036854775807 && $c == 9223372036854775808; + print "ok 28\n"; + + $a = -9223372036854775808; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 29\n"; + + $a = -9223372036854775808; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 30\n"; + + $a = -9223372036854775808; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 31\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 32\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 33\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 34\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = $b--; + print "not " + unless $b == -$a-1 && $c == -$a; + print "ok 35\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = --$b; + print "not " + unless $b == -$a-1 && $c == $b; + print "ok 36\n"; + + $a = 9223372036854775808; + $b = -$a; + $b = $b - 1; + print "not " + unless $b == -(++$a); + print "ok 37\n"; + +} else { + # Unicos has imprecise doubles (14 decimal digits or so), + # especially if operating near the UV/IV limits the low-order bits + # become mangled even by simple arithmetic operations. + for (23..37) { + print "ok $_ # skipped: too imprecise numbers\n"; + } +} $x = ''; @@ -233,10 +254,44 @@ print "ok 45\n"; print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; print "ok 46\n"; -print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "not " + unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; print "ok 47\n"; -print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "not " + unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; print "ok 48\n"; + +print "not " + unless (sprintf "%b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 49\n"; + +print "not " + unless (sprintf "%64b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 50\n"; + +print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; +print "ok 51\n"; + +print "not " unless (sprintf "%u", ~0) eq '18446744073709551615'; +print "ok 52\n"; + +# If the 53..55 fail you have problems in the parser's string->int conversion, +# see toke.c:scan_num(). + +$q = -9223372036854775808; +print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808"; +print "ok 53\n"; + +$q = 9223372036854775807; +print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807"; +print "ok 54\n"; + +$q = 18446744073709551615; +print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; +print "ok 55\n"; + # eof diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t index d115146..5aa4bf9 100755 --- a/contrib/perl5/t/op/append.t +++ b/contrib/perl5/t/op/append.t @@ -2,7 +2,7 @@ # $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ -print "1..3\n"; +print "1..13\n"; $a = 'ab' . 'c'; # compile time $b = 'def'; @@ -19,3 +19,41 @@ $_ = $a; $_ .= $b; print "#3\t:$_: eq :abcdef:\n"; if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} + +# test that when right argument of concat is UTF8, and is the same +# variable as the target, and the left argument is not UTF8, it no +# longer frees the wrong string. +{ + sub r2 { + my $string = ''; + $string .= pack("U0a*", 'mnopqrstuvwx'); + $string = "abcdefghijkl$string"; + } + + r2() and print "ok $_\n" for qw/ 4 5 /; +} + +# test that nul bytes get copied +{ +# Character 'b' occurs at codepoint 130 decimal or \202 octal +# under an EBCDIC coded character set. +# my($a, $ab) = ("a", "a\000b"); + my($a, $ab) = ("\141", "\141\000\142"); + my($u, $ub) = map pack("U0a*", $_), $a, $ab; + my $t1 = $a; $t1 .= $ab; + print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n"; + my $t2 = $a; $t2 .= $ub; + print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n"; + my $t3 = $u; $t3 .= $ab; + print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n"; + my $t4 = $u; $t4 .= $ub; + print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n"; + my $t5 = $a; $t5 = $ab . $t5; + print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n"; + my $t6 = $a; $t6 = $ub . $t6; + print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n"; + my $t7 = $u; $t7 = $ab . $t7; + print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n"; + my $t8 = $u; $t8 = $ub . $t8; + print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n"; +} diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t index 48bf5afe..ce2c398 100755 --- a/contrib/perl5/t/op/args.t +++ b/contrib/perl5/t/op/args.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; # test various operations on @_ @@ -52,3 +52,24 @@ sub new4 { goto &new2 } print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; print "ok $ord\n"; } + +# see if POPSUB gets to see the right pad across a dounwind() with +# a reified @_ + +sub methimpl { + my $refarg = \@_; + die( "got: @_\n" ); +} + +sub method { + &methimpl; +} + +sub try { + eval { method('foo', 'bar'); }; + print "# $@" if $@; +} + +for (1..5) { try() } +++$ord; +print "ok $ord\n"; diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t index fe2f0f4..5b04f93 100755 --- a/contrib/perl5/t/op/arith.t +++ b/contrib/perl5/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..12\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -21,3 +21,10 @@ try 5, abs( 13e21 % 4e21 - 1e21) < $limit; try 6, abs(-13e21 % 4e21 - 3e21) < $limit; try 7, abs( 13e21 % -4e21 - -3e21) < $limit; try 8, abs(-13e21 % -4e21 - -1e21) < $limit; + +# UVs should behave properly + +try 9, 4063328477 % 65535 == 27407; +try 10, 4063328477 % 4063328476 == 1; +try 11, 4063328477 % 2031664238 == 1; +try 12, 2031664238 % 4063328477 == 2031664238; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 1108f49..7cc84e3 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..66\n"; +print "1..70\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -139,8 +139,8 @@ t("@foo" eq "bar burbl blah"); # 39 @foo = ('XXX',@foo, 'YYY'); t("@foo" eq "XXX bar burbl blah YYY"); # 40 -@foo = @foo = qw(foo bar burbl blah); -t("@foo" eq "foo bar burbl blah"); # 41 +@foo = @foo = qw(foo b\a\r bu\\rbl blah); +t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 @bar = @foo = qw(foo bar); # 42 t("@foo" eq "foo bar"); @@ -216,3 +216,16 @@ reify('ok'); print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; print "ok 66\n"; +@ary = (12,23,34,45,56); + +print "not " unless shift(@ary) == 12; +print "ok 67\n"; + +print "not " unless pop(@ary) == 56; +print "ok 68\n"; + +print "not " unless push(@ary,56) == 4; +print "ok 69\n"; + +print "not " unless unshift(@ary,12) == 5; +print "ok 70\n"; diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t index b95cec5..aff433c 100755 --- a/contrib/perl5/t/op/assignwarn.t +++ b/contrib/perl5/t/op/assignwarn.t @@ -8,7 +8,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; @@ -21,7 +21,7 @@ sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } -print "1..23\n"; +print "1..32\n"; { my $x; $x ++; ok 1, ! uninitialized; } { my $x; $x --; ok 2, ! uninitialized; } @@ -55,7 +55,19 @@ print "1..23\n"; { my $x; $x |= "x"; ok 21, ! uninitialized; } { my $x; $x ^= "x"; ok 22, ! uninitialized; } -ok 23, $warn eq ''; +{ use integer; my $x; $x += 1; ok 23, ! uninitialized; } +{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; } + +{ use integer; my $x; $x *= 1; ok 25, uninitialized; } +{ use integer; my $x; $x /= 1; ok 26, uninitialized; } +{ use integer; my $x; $x %= 1; ok 27, uninitialized; } + +{ use integer; my $x; $x ++; ok 28, ! uninitialized; } +{ use integer; my $x; $x --; ok 29, ! uninitialized; } +{ use integer; my $x; ++ $x; ok 30, ! uninitialized; } +{ use integer; my $x; -- $x; ok 31, ! uninitialized; } + +ok 32, $warn eq ''; # If we got any errors that we were not expecting, then print them print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t index 615e4d3..2702004 100755 --- a/contrib/perl5/t/op/attrs.t +++ b/contrib/perl5/t/op/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } sub NTESTS () ; diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t index cd7c957..5b91fd2 100755 --- a/contrib/perl5/t/op/avhv.t +++ b/contrib/perl5/t/op/avhv.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } require Tie::Array; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t index 7bcabdf..0354f00 100755 --- a/contrib/perl5/t/op/bop.t +++ b/contrib/perl5/t/op/bop.t @@ -6,10 +6,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..30\n"; +print "1..44\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -39,7 +39,7 @@ print (((1 << ($bits - 1)) == $cusp && do { use integer; 1 << ($bits - 1) } == -$cusp) ? "ok 11\n" : "not ok 11\n"); print ((($cusp >> 1) == ($cusp / 2) && - do { use integer; $cusp >> 1 } == -($cusp / 2)) + do { use integer; abs($cusp >> 1) } == ($cusp / 2)) ? "ok 12\n" : "not ok 12\n"); $Aaz = chr(ord("A") & ord("z")); @@ -81,3 +81,91 @@ print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; +# +print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256'; +print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444'; +print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188'; +# +my $a = v120.300; +my $b = v200.400; +$a ^= $b; +print "ok 34\n" if sprintf("%vd", $a) eq '176.188'; +my $a = v120.300; +my $b = v200.400; +$a |= $b; +print "ok 35\n" if sprintf("%vd", $a) eq '248.444'; + +# +# UTF8 ~ behaviour +# + +my @not36; + +for (0x100...0xFFF) { + $a = ~(chr $_); + push @not36, sprintf("%#03X", $_) + if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); +} +if (@not36) { + print "# test 36 failed\n"; + print "not "; +} +print "ok 36\n"; + +my @not37; + +for my $i (0xEEE...0xF00) { + for my $j (0x0..0x120) { + $a = ~(chr ($i) . chr $j); + push @not37, sprintf("%#03X %#03X", $i, $j) + if $a ne chr(~$i).chr(~$j) or + length($a) != 2 or + ~$a ne chr($i).chr($j); + } +} +if (@not37) { + print "# test 37 failed\n"; + print "not "; +} +print "ok 37\n"; + +print "not " unless ~chr(~0) eq "\0"; +print "ok 38\n"; + +my @not39; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not39, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); + } +} +if (@not39) { + print "# test 39 failed\n"; + print "not "; +} +print "ok 39\n"; + +my @not40; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not40, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); + } +} +if (@not40) { + print "# test 40 failed\n"; + print "not "; +} +print "ok 40\n"; + +# More variations on 19 and 22. +print "ok \xFF\x{FF}\n" & "ok 41\n"; +print "ok \x{FF}\xFF\n" & "ok 42\n"; + +# Tests to see if you really can do casts negative floats to unsigned properly +$neg1 = -1.0; +print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n"); +$neg7 = -7.0; +print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n"); diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t index 6723ca3..1b55f11 100755 --- a/contrib/perl5/t/op/chop.t +++ b/contrib/perl5/t/op/chop.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..37\n"; # optimized @@ -89,3 +89,30 @@ $_ = "ab\n"; $/ = \3; print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; + +# Go Unicode. + +$_ = "abc\x{1234}"; +chop; +print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; + +$_ = "abc\x{1234}d"; +chop; +print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; + +$_ = "\x{1234}\x{2345}"; +chop; +print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; + +my @stuff = qw(this that); +print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; + +# bug id 20010305.012 +@stuff = qw(ab cd ef); +print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; + +@stuff = qw(ab cd ef); +print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; + +my %stuff = (1..4); +print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t index c691d6f..5f3245f 100755 --- a/contrib/perl5/t/op/closure.t +++ b/contrib/perl5/t/op/closure.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t index 9e714a7..33c74ea 100755 --- a/contrib/perl5/t/op/defins.t +++ b/contrib/perl5/t/op/defins.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { $warns++; warn $_[0] }; print "1..14\n"; } diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index cb0478b..a389946 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -e '../lib'; + @INC = '../lib'; } if ($^O eq 'mpeix') { diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t index 3363dfd..d4aa292 100755 --- a/contrib/perl5/t/op/exists_sub.t +++ b/contrib/perl5/t/op/exists_sub.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..9\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t index e00d5fb..f757c79 100755 --- a/contrib/perl5/t/op/filetest.t +++ b/contrib/perl5/t/op/filetest.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t index 20167f3..99b22ef 100755 --- a/contrib/perl5/t/op/flip.t +++ b/contrib/perl5/t/op/flip.t @@ -2,7 +2,7 @@ # $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ -print "1..9\n"; +print "1..10\n"; @a = (1,2,3,4,5,6,7,8,9,10,11,12); @@ -17,7 +17,7 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} @a = ('a','b','c','d','e','f','g'); -open(of,'../Configure'); +open(of,'harness') or die "Can't open harness: $!"; while (<of>) { (3 .. 5) && ($foo .= $_); } @@ -27,3 +27,10 @@ if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} $x = 3.14; if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";} + +{ + # coredump reported in bug 20001018.008 + readline(UNKNOWN); + $. = 1; + print "ok 10\n" unless 1 .. 10; +} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t index 80c0b72..88b6b4b 100755 --- a/contrib/perl5/t/op/fork.t +++ b/contrib/perl5/t/op/fork.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'} or ($^O eq 'MSWin32' and $Config{useithreads} @@ -184,6 +184,28 @@ child 3 [1] -2- -3- -1- -2- -3- ######## +$| = 1; +foreach my $c (1,2,3) { + if (fork) { + print "parent $c\n"; + } + else { + print "child $c\n"; + exit; + } +} +while (wait() != -1) { print "waited\n" } +EXPECT +child 1 +child 2 +child 3 +parent 1 +parent 2 +parent 3 +waited +waited +waited +######## use Config; $| = 1; $\ = "\n"; @@ -374,3 +396,28 @@ else { EXPECT pipe_from_fork pipe_to_fork +######## +$|=1; +if ($pid = fork()) { + print "forked first kid\n"; + print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; +} +else { + print "first child\n"; + exit(0); +} +if ($pid = fork()) { + print "forked second kid\n"; + print "wait() returned ok\n" if wait() == $pid; +} +else { + print "second child\n"; + exit(0); +} +EXPECT +forked first kid +first child +waitpid() returned ok +forked second kid +second child +wait() returned ok diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t index 4c27445..fc0ba77 100755 --- a/contrib/perl5/t/op/glob.t +++ b/contrib/perl5/t/op/glob.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..6\n"; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t index 8d9bca1..cf2cafd 100755 --- a/contrib/perl5/t/op/goto_xs.t +++ b/contrib/perl5/t/op/goto_xs.t @@ -10,7 +10,7 @@ # break correctly as well. chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; # turn warnings into fatal errors diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t index 761d8b9..211dc91 100755 --- a/contrib/perl5/t/op/grent.t +++ b/contrib/perl5/t/op/grent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getgrgid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -54,9 +54,9 @@ BEGIN { } } -# By now GR filehandle should be open and full of juicy group entries. +# By now the GR filehandle should be open and full of juicy group entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many groups. # (note that the first entry has been read away by now) @@ -67,9 +67,11 @@ my $tst = 1; my %perfect; my %seen; +setgrent(); while (<GR>) { chomp; - my @s = split /:/; + # LIMIT -1 so that groups with no users don't fall off + my @s = split /:/, $_, -1; my ($name_s,$passwd_s,$gid_s,$members_s) = @s; if (@s) { push @{ $seen{$name_s} }, $.; @@ -111,6 +113,8 @@ while (<GR>) { $n++; } +endgrent(); + if (keys %perfect == 0) { $max++; print <<EOEX; @@ -136,4 +140,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @gr1; + +setgrent(); +for (1..$max) { + my $gr = scalar getgrent(); + last unless defined $gr; + push @gr1, $gr; +} +endgrent(); + +my @gr2; + +setgrent(); +for (1..$max) { + my ($gr) = (getgrent()); + last unless defined $gr; + push @gr2, $gr; +} +endgrent(); + +print "not " unless "@gr1" eq "@gr2"; +print "ok ", $tst++, "\n"; + close(GR); diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t index 4b655c8..082d2d1 100755 --- a/contrib/perl5/t/op/groups.t +++ b/contrib/perl5/t/op/groups.t @@ -115,7 +115,8 @@ for (split(' ', $()) { } } -if ($^O eq "uwin") { # Or anybody else who can have spaces in group names. +if ($^O =~ /^(?:uwin|solaris)$/) { + # Or anybody else who can have spaces in group names. $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); } else { $gr1 = join(' ', sort @gr); diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t index 04905cd..8311244 100755 --- a/contrib/perl5/t/op/gv.t +++ b/contrib/perl5/t/op/gv.t @@ -6,12 +6,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..30\n"; +print "1..40\n"; # type coersion on assignment $foo = 'foo'; @@ -128,6 +128,42 @@ print {*x{FILEHANDLE}} "ok 23\n"; ++$test; &{$a}; } +# although it *should* if you're talking about magicals + +{ + my $test = 29; + + my $a = "]"; + print "not " unless defined ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + + $a = "1"; + "o" =~ /(o)/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "2"; + print "not " if ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "1x"; + print "not " if defined ${$a}; + ++$test; print "ok $test\n"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + $a = "11"; + "o" =~ /(((((((((((o)))))))))))/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; +} + + # does pp_readline() handle glob-ness correctly? { @@ -137,4 +173,4 @@ print {*x{FILEHANDLE}} "ok 23\n"; } __END__ -ok 30 +ok 40 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t index 9182273..8466a71 100755 --- a/contrib/perl5/t/op/hashwarn.t +++ b/contrib/perl5/t/op/hashwarn.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t index 6ac0866..7d675a4 100755 --- a/contrib/perl5/t/op/int.t +++ b/contrib/perl5/t/op/int.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..6\n"; +print "1..7\n"; # compile time evaluation @@ -28,3 +28,9 @@ print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; $y = (3/-10)*-10; print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; } + +# check bad strings still get converted + +@x = ( 6, 8, 10); +print "not " if $x["1foo"] != 8; +print "ok 7\n"; diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t index def5a9e..0f849fd 100755 --- a/contrib/perl5/t/op/join.t +++ b/contrib/perl5/t/op/join.t @@ -1,6 +1,6 @@ #!./perl -print "1..6\n"; +print "1..14\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} @@ -20,3 +20,48 @@ if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} $f = 'a'; $f = join $f, 'b', 'e', 'k'; if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} + +# 7,8 check for multiple read of tied objects +{ package X; + sub TIESCALAR { my $x = 7; bless \$x }; + sub FETCH { my $y = shift; $$y += 5 }; + tie my $t, 'X'; + my $r = join ':', $t, 99, $t, 99; + print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; + print "ok 7\n"; + $r = join '', $t, 99, $t, 99; + print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; + print "ok 8\n"; +}; + +# 9,10 and for multiple read of undef +{ my $s = 5; + local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); + my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; + print "ok 9\n"; + my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; + print "ok 10\n"; +}; + +{ my $s = join("", chr(0x1234), chr(0xff)); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 11\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), ""); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 12\n"; +} + +{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); + print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; + print "ok 13\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); + print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; + print "ok 14\n"; +} + diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t index 2fb059d..d761f73 100755 --- a/contrib/perl5/t/op/lex_assign.t +++ b/contrib/perl5/t/op/lex_assign.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; umask 0; $xref = \ ""; @@ -112,11 +111,12 @@ for (@INPUT) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; $op = "$op==$op" unless $op =~ /==/; ($op, $expectop) = $op =~ /(.*)==(.*)/; $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) - ? "skip" : "not"; + ? "skip" : "# '$_'\nnot"; $integer = ($comment =~ /^i_/) ? "use integer" : '' ; (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; @@ -137,7 +137,7 @@ EOE print "# skipping $comment: unimplemented:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } @@ -146,6 +146,7 @@ for (@simple_input) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; eval <<EOE; local \$SIG{__WARN__} = \\&wrn; @@ -164,14 +165,14 @@ EOE print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } __END__ ref $xref # ref ref $cstr # ref nonref -`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32) `$undefed` # backtick undef skip(MSWin32) <*> # glob <OP> # readline @@ -242,7 +243,7 @@ lc $cstr # lc quotemeta $cstr # quotemeta @$aref # rv2av @$undefed # rv2av undef -each %h==1 # each +(each %h) % 2 == 1 # each values %h # values keys %h # keys %$href # rv2hv @@ -307,7 +308,7 @@ getpriority $$, $$ # getpriority time # time localtime $^T # localtime gmtime $^T # gmtime -sleep 1 # sleep +'???' # sleep: can randomly fail '???' # alarm '???' # shmget '???' # shmctl diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t index e704f6f..0a1c399 100755 --- a/contrib/perl5/t/op/lfs.t +++ b/contrib/perl5/t/op/lfs.t @@ -4,15 +4,20 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; # Don't bother if there are no quad offsets. require Config; import Config; if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -25,35 +30,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + print <<EOM; # -# If the lfs (large file support: large meaning larger than two gigabytes) -# tests are skipped or fail, it may mean either that your process -# (or process group) is not allowed to write large files (resource -# limits) or that the file system you are running the tests on doesn't -# let your user/group have large files (quota) or the filesystem simply -# doesn't support large files. You may even need to reconfigure your kernel. -# (This is all very operating system and site-dependent.) +# If the lfs (large file support: large meaning larger than two +# gigabytes) tests are skipped or fail, it may mean either that your +# process (or process group) is not allowed to write large files +# (resource limits) or that the file system (the network filesystem?) +# you are running the tests on doesn't let your user/group have large +# files (quota) or the filesystem simply doesn't support large files. +# You may even need to reconfigure your kernel. (This is all very +# operating system and site-dependent.) # # Perl may still be able to support large files, once you have # such a process, enough quota, and such a (file) system. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } print "# checking whether we have sparse files...\n"; # Known have-nots. -if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^O\n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -102,7 +114,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -110,14 +122,22 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-e', <<'EOF'; +open(BIG, ">big"); +seek(BIG, 5_000_000_000, 0); +print BIG "big"; +exit 0; +EOF + open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; -unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { - print "1..0\n# seeking past 2GB failed: $!\n"; - explain(); +if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { + my $err = $r ? 'signal '.($r & 0x7f) : $!; + explain("seeking past 2GB failed: $err"); bye(); } @@ -129,11 +149,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -142,8 +163,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -152,9 +172,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -174,25 +215,28 @@ binmode BIG; fail unless seek(BIG, 4_500_000_000, $SEEK_SET); print "ok 5\n"; -fail unless tell(BIG) == 4_500_000_000; +offset('tell(BIG)', 4_500_000_000); print "ok 6\n"; fail unless seek(BIG, 1, $SEEK_CUR); print "ok 7\n"; -fail unless tell(BIG) == 4_500_000_001; +# If you get 205_032_705 from here it means that +# your tell() is returning 32-bit values since (I32)4_500_000_001 +# is exactly 205_032_705. +offset('tell(BIG)', 4_500_000_001); print "ok 8\n"; fail unless seek(BIG, -1, $SEEK_CUR); print "ok 9\n"; -fail unless tell(BIG) == 4_500_000_000; +offset('tell(BIG)', 4_500_000_000); print "ok 10\n"; fail unless seek(BIG, -3, $SEEK_END); print "ok 11\n"; -fail unless tell(BIG) == 5_000_000_000; +offset('tell(BIG)', 5_000_000_000); print "ok 12\n"; my $big; @@ -204,6 +248,8 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. fail unless seek(BIG, 705_032_704, $SEEK_SET); print "ok 15\n"; @@ -215,7 +261,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t index b478e01..cf606b7 100755 --- a/contrib/perl5/t/op/local.t +++ b/contrib/perl5/t/op/local.t @@ -2,9 +2,6 @@ print "1..69\n"; -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - sub foo { local($a, $b) = @_; local($c, $d); diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t index f15201f..d57271a 100755 --- a/contrib/perl5/t/op/lop.t +++ b/contrib/perl5/t/op/lop.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..7\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t index 7739276..c2a8211 100755 --- a/contrib/perl5/t/op/magic.t +++ b/contrib/perl5/t/op/magic.t @@ -3,7 +3,7 @@ BEGIN { $| = 1; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } @@ -189,16 +189,18 @@ if ($Is_VMS || $Is_Dos) { } else { $PATH = $ENV{PATH}; + $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; $ENV{foo} = "bar"; %ENV = (); $ENV{PATH} = $PATH; + $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "") : (`echo \$foo` eq "\n") ); - $ENV{NoNeSuCh} = "foo"; + $ENV{__NoNeSuCh} = "foo"; $0 = "bar"; - ok 30, ($Is_MSWin32 ? (`cmd /x /c set NoNeSuCh` eq "NoNeSuCh=foo\n") - : (`echo \$NoNeSuCh` eq "foo\n") ); + ok 30, ($Is_MSWin32 ? (`cmd /x /c set __NoNeSuCh` eq "__NoNeSuCh=foo\n") + : (`echo \$__NoNeSuCh` eq "foo\n") ); } { diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t index 1c6f3c5..be4df75 100755 --- a/contrib/perl5/t/op/method.t +++ b/contrib/perl5/t/op/method.t @@ -4,7 +4,12 @@ # test method calls and autoloading. # -print "1..49\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..53\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -167,3 +172,16 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); test(A2->foo(), "foo"); } + +{ + test(do { use Config; eval 'Config->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); + test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +} + +test(do { eval 'E->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "E"; $e->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); + diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index ac1a44f..35437a4 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -4,7 +4,7 @@ # separate executable and can't simply use eval. chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -15,7 +15,7 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "misctmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { while($tmpfile && unlink $tmpfile){} } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); @@ -26,6 +26,9 @@ for (@prgs){ } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; + $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking + print TEST $prog, "\n"; close TEST or die "Cannot close $tmpfile: $!"; @@ -59,12 +62,12 @@ $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## -use integer; $cusp = ~0 ^ (~0 >> 1); +use integer; $, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; EXPECT --1 0 0 1 ! +7 0 0 8 ! ######## $foo=undef; $foo->go; EXPECT @@ -346,7 +349,7 @@ print "you die joe!\n" unless "@x" eq 'x y z'; /(?{"{"})/ # Check it outside of eval too EXPECT Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern -/(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1. +Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too EXPECT @@ -371,8 +374,8 @@ argv <e> # fdopen from a system descriptor to a system descriptor used to close # the former. open STDERR, '>&=STDOUT' or die $!; -select STDOUT; $| = 1; print fileno STDOUT; -select STDERR; $| = 1; print fileno STDERR; +select STDOUT; $| = 1; print fileno STDOUT or die $!; +select STDERR; $| = 1; print fileno STDERR or die $!; EXPECT 1 2 @@ -545,3 +548,56 @@ ucfirst - World lcfirst - world uc - WORLD lc - world +######## +sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } +my $x = "foo"; +{ f } continue { print $x, "\n" } +EXPECT +foo +######## +sub C () { 1 } +sub M { $_[0] = 2; } +eval "C"; +M(C); +EXPECT +Modification of a read-only value attempted at - line 2. +######## +print qw(ab a\b a\\b); +EXPECT +aba\ba\b +######## +# This test is here instead of pragma/locale.t because +# the bug depends on in the internal state of the locale +# settings and pragma/locale messes up that state pretty badly. +# We need a "fresh run". +BEGIN { + eval { require POSIX }; + if ($@) { + exit(0); # running minitest? + } +} +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +$have_setlocale = 0 if $@; +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +# and mingw32 uses said silly CRT +$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; +exit(0) unless $have_setlocale; +my @locales; +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { + while(<LOCALES>) { + chomp; + push(@locales, $_); + } + close(LOCALES); +} +exit(0) unless @locales; +for (@locales) { + use POSIX qw(locale_h); + use locale; + setlocale(LC_NUMERIC, $_) or next; + my $s = sprintf "%g %g", 3.1, 3.1; + next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; + print "$_ $s\n"; +} +EXPECT diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index cf8e55d..c5a090c 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -4,7 +4,7 @@ print "1..9\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t index 1777e88..601e1d6 100755 --- a/contrib/perl5/t/op/my.t +++ b/contrib/perl5/t/op/my.t @@ -2,7 +2,7 @@ # $RCSfile: my.t,v $ -print "1..30\n"; +print "1..31\n"; sub foo { my($a, $b) = @_; @@ -92,3 +92,10 @@ print +(@x ? "not " : ""), "ok 29\n"; { @x = my %y } print +(@x ? "not " : ""), "ok 30\n"; +# Found in HTML::FormatPS +my %fonts = qw(nok 31); +for my $full (keys %fonts) { + $full =~ s/^n//; + # Supposed to be copy-on-write via force_normal after a THINKFIRST check. + print "$full $fonts{nok}\n"; +} diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t index fd36e2e..411a0b4 100755 --- a/contrib/perl5/t/op/nothr5005.t +++ b/contrib/perl5/t/op/nothr5005.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; require Config; import Config; if ($Config{'use5005threads'}) diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t index 8eb9b6e..f3c9867 100755 --- a/contrib/perl5/t/op/numconvert.t +++ b/contrib/perl5/t/op/numconvert.t @@ -51,7 +51,13 @@ my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { - print "1..0\n# Unsigned arithmetic is not sane\n"; + print "1..0 # skipped: unsigned perl arithmetic is not sane"; + eval { require Config; import Config }; + use vars qw(%Config); + if ($Config{d_quad} eq 'define') { + print " (common in 64-bit platforms)"; + } + print "\n"; exit 0; } diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 27ac5aa..fe155d3 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,53 +1,88 @@ #!./perl -print "1..36\n"; +print "1..50\n"; -print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n"; -print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n"; -print +(oct('0b10101') == 21) ? "ok" : "not ok", " 3\n"; -print +(oct('0b10101') == 0x15) ? "ok" : "not ok", " 4\n"; +print +(oct('0b1_0101') == 0b101_01) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10_101') == 0_2_5) ? "ok" : "not ok", " 2\n"; +print +(oct('0b101_01') == 2_1) ? "ok" : "not ok", " 3\n"; +print +(oct('0b1010_1') == 0x1_5) ? "ok" : "not ok", " 4\n"; -print +(oct('b10101') == 0b10101) ? "ok" : "not ok", " 5\n"; -print +(oct('b10101') == 025) ? "ok" : "not ok", " 6\n"; -print +(oct('b10101') == 21) ? "ok" : "not ok", " 7\n"; -print +(oct('b10101') == 0x15) ? "ok" : "not ok", " 8\n"; +print +(oct('b1_0101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10_101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b101_01') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b1010_1') == 0x15) ? "ok" : "not ok", " 8\n"; -print +(oct('01234') == 0b1010011100) ? "ok" : "not ok", " 9\n"; -print +(oct('01234') == 01234) ? "ok" : "not ok", " 10\n"; -print +(oct('01234') == 668) ? "ok" : "not ok", " 11\n"; +print +(oct('01_234') == 0b10_1001_1100) ? "ok" : "not ok", " 9\n"; +print +(oct('012_34') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('0123_4') == 668) ? "ok" : "not ok", " 11\n"; print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; -print +(oct('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 13\n"; -print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n"; -print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n"; -print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n"; +print +(oct('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x12_34') == 01_1064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x123_4') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x12_34) ? "ok" : "not ok", " 16\n"; -print +(oct('x1234') == 0b1001000110100) ? "ok" : "not ok", " 17\n"; -print +(oct('x1234') == 011064) ? "ok" : "not ok", " 18\n"; -print +(oct('x1234') == 4660) ? "ok" : "not ok", " 19\n"; -print +(oct('x1234') == 0x1234) ? "ok" : "not ok", " 20\n"; +print +(oct('x1_234') == 0b100100011010_0) ? "ok" : "not ok", " 17\n"; +print +(oct('x12_34') == 0_11064) ? "ok" : "not ok", " 18\n"; +print +(oct('x123_4') == 4660) ? "ok" : "not ok", " 19\n"; +print +(oct('x1234') == 0x_1234) ? "ok" : "not ok", " 20\n"; -print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 21\n"; -print +(hex('01234') == 011064) ? "ok" : "not ok", " 22\n"; -print +(hex('01234') == 4660) ? "ok" : "not ok", " 23\n"; -print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 24\n"; +print +(hex('01_234') == 0b_1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('012_34') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('0123_4') == 4660) ? "ok" : "not ok", " 23\n"; +print +(hex('01234_') == 0x1234) ? "ok" : "not ok", " 24\n"; -print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; -print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 26\n"; -print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 27\n"; -print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 28\n"; +print +(hex('0x_1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; +print +(hex('0x1_234') == 011064) ? "ok" : "not ok", " 26\n"; +print +(hex('0x12_34') == 4660) ? "ok" : "not ok", " 27\n"; +print +(hex('0x1234_') == 0x1234) ? "ok" : "not ok", " 28\n"; -print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; -print +(hex('x1234') == 011064) ? "ok" : "not ok", " 30\n"; -print +(hex('x1234') == 4660) ? "ok" : "not ok", " 31\n"; -print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 32\n"; +print +(hex('x_1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; +print +(hex('x12_34') == 011064) ? "ok" : "not ok", " 30\n"; +print +(hex('x123_4') == 4660) ? "ok" : "not ok", " 31\n"; +print +(hex('x1234_') == 0x1234) ? "ok" : "not ok", " 32\n"; -print +(oct('0b11111111111111111111111111111111') == 4294967295) ? +print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ? "ok" : "not ok", " 33\n"; -print +(oct('037777777777') == 4294967295) ? +print +(oct('037_777_777_777') == 4294967295) ? "ok" : "not ok", " 34\n"; -print +(oct('0xffffffff') == 4294967295) ? +print +(oct('0xffff_ffff') == 4294967295) ? "ok" : "not ok", " 35\n"; -print +(hex('0xffffffff') == 4294967295) ? +print +(hex('0xff_ff_ff_ff') == 4294967295) ? "ok" : "not ok", " 36\n"; + +$_ = "\0_7_7"; +print length eq 5 ? "ok" : "not ok", " 37\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 39\n"; +if (ord("\t") != 9) { + # question mark is 111 in 1047, 037, && POSIX-BC + print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; +} +else { + print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; +} + +$_ = "\x_7_7"; +print length eq 5 ? "ok" : "not ok", " 41\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 43\n"; +if (ord("\t") != 9) { + # / is 97 in 1047, 037, && POSIX-BC + print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; +} +else { + print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; +} + +print +(oct('0b'.( '0'x10).'1_0101') == 0b101_01) ? "ok" : "not ok", " 45\n"; +print +(oct('0b'.( '0'x100).'1_0101') == 0b101_01) ? "ok" : "not ok", " 46\n"; +print +(oct('0b'.('0'x1000).'1_0101') == 0b101_01) ? "ok" : "not ok", " 47\n"; + +print +(hex(( '0'x10).'01234') == 0x1234) ? "ok" : "not ok", " 48\n"; +print +(hex(( '0'x100).'01234') == 0x1234) ? "ok" : "not ok", " 49\n"; +print +(hex(('0'x1000).'01234') == 0x1234) ? "ok" : "not ok", " 50\n"; + diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index b336cb5..67bd547 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..156\n"; +print "1..159\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -372,8 +372,9 @@ print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; eval { ($x) = pack '/a*','hello' }; print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n/a* w/A*','string','etc'; -print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; +$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; +print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc"; +print "ok $test\n"; $test++; eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; @@ -405,3 +406,13 @@ $z = pack <<EOP,'string','etc'; w/A* # Count a BER integer EOP print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless "1.20.300.4000" eq + sprintf "%vd", pack(" U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless v1.20.300.4000 ne + sprintf "%vd", pack("C0U*",1,20,300,4000); +print "ok $test\n"; $test++; + diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index 188a3a3..ffbc945 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,17 +4,14 @@ # 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..211\n"; +print "1..231\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } eval 'use Config'; # Defaults assumed if this fails -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - $x = "abc\ndef\n"; if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} @@ -266,12 +263,12 @@ print "ok 68\n"; undef $@; eval "'aaa' =~ /a{1,$reg_infty}/"; -print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%; +print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 69\n"; eval "'aaa' =~ /a{1,$reg_infty_p}/"; print "not " - if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%; + if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 70\n"; undef $@; @@ -279,7 +276,7 @@ undef $@; $context = 'x' x 256; eval qq("${context}y" =~ /(?<=$context)y/); -print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; +print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; print "ok 71\n"; # removed test @@ -496,7 +493,7 @@ $test++; $_ = 'xabcx'; foreach $ans ('', 'c') { /(?<=(?=a)..)((?=c)|.)/g; - print "not " unless $1 eq $ans; + print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; print "ok $test\n"; $test++; } @@ -504,7 +501,7 @@ foreach $ans ('', 'c') { $_ = 'a'; foreach $ans ('', 'a', '') { /^|a|$/g; - print "not " unless $& eq $ans; + print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; print "ok $test\n"; $test++; } @@ -545,6 +542,22 @@ $test++; print "ok $test\n"; $test++; + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; + + no re "eval"; $match = eval { /$a$c$a/ }; print "not " @@ -554,6 +567,23 @@ $test++; } { + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; +} + +{ package aa; $c = 2; $::c = 3; @@ -588,8 +618,12 @@ sub make_must_warn { my $for_future = make_must_warn('reserved for future extensions'); &$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); -&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); + +#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); +print "ok $test\n"; $test++; # now a fatal croak + +#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); +print "ok $test\n"; $test++; # now a fatal croak # test if failure of patterns returns empty list $_ = 'aaa'; @@ -689,6 +723,30 @@ print "not " print "ok $test\n"; $test++; +eval { $+[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { $-[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @+ = (7, 6, 5); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @- = qw(foo bar); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + /.(a)(ba*)?/; print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; print "ok $test\n"; @@ -995,3 +1053,78 @@ $test++; "\n\n" =~ /\n+ $ \n/x or print "not "; print "ok $test\n"; $test++; + +[] =~ /^ARRAY/ or print "# [] \nnot "; +print "ok $test\n"; +$test++; + +eval << 'EOE'; +{ + package S; + use overload '""' => sub { 'Object S' }; + sub new { bless [] } +} +$a = 'S'->new; +EOE + +$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; +print "ok $test\n"; +$test++; + +# test result of match used as match (!) +'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +$w = 0; +{ + local $SIG{__WARN__} = sub { $w = 1 }; + local $^W = 1; + $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; +} +print $w ? "not " : "", "ok $test\n"; +$test++; + +my %space = ( spc => " ", + tab => "\t", + cr => "\r", + lf => "\n", + ff => "\f", +# There's no \v but the vertical tabulator seems miraculously +# be 11 both in ASCII and EBCDIC. + vt => chr(11), + false => "space" ); + +my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; +my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; +my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; + +print "not " unless "@space0" eq "cr ff lf spc tab"; +print "ok $test # @space0\n"; +$test++; + +print "not " unless "@space1" eq "cr ff lf spc tab vt"; +print "ok $test # @space1\n"; +$test++; + +print "not " unless "@space2" eq "spc tab"; +print "ok $test # @space2\n"; +$test++; + +# bugid 20001021.005 - this caused a SEGV +print "not " unless undef =~ /^([^\/]*)(.*)$/; +print "ok $test\n"; +$test++; + +{ + # japhy -- added 03/03/2001 + () = (my $str = "abc") =~ /(...)/; + $str = "def"; + print "not " if $1 ne "abc"; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t index 46811b7..f3bc23c 100755 --- a/contrib/perl5/t/op/pos.t +++ b/contrib/perl5/t/op/pos.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..4\n"; $x='banana'; $x=~/.a/g; @@ -14,3 +14,10 @@ sub f { my $p=$_[0]; return $p } $x=~/.a/g; if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} +# Is pos() set inside //g? (bug id 19990615.008) +$x = "test string?"; $x =~ s/\w/pos($x)/eg; +print "not " unless $x eq "0123 5678910?"; +print "ok 4\n"; + + + diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t index ca14a99..d811f06 100755 --- a/contrib/perl5/t/op/pwent.t +++ b/contrib/perl5/t/op/pwent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getpwuid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -55,9 +55,9 @@ BEGIN { } } -# By now PW filehandle should be open and full of juicy password entries. +# By now the PW filehandle should be open and full of juicy password entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many users. # (note that the first entry has been read away by now) @@ -68,10 +68,17 @@ my $tst = 1; my %perfect; my %seen; +setpwent(); while (<PW>) { chomp; - my @s = split /:/; - my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + # LIMIT -1 so that users with empty shells don't fall off + my @s = split /:/, $_, -1; + my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); + if ($^O eq 'darwin') { + ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; + } else { + ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + } next if /^\+/; # ignore NIS includes if (@s) { push @{ $seen{$name_s} }, $.; @@ -86,7 +93,7 @@ while (<PW>) { } # In principle we could whine if @s != 7 but do we know enough # of passwd file formats everywhere? - if (@s == 7) { + if (@s == 7 || ($^O eq 'darwin' && @s == 10)) { @n = getpwuid($uid_s); # 'nobody' et al. next unless @n; @@ -108,6 +115,7 @@ while (<PW>) { } $n++; } +endpwent(); if (keys %perfect == 0) { $max++; @@ -134,4 +142,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @pw1; + +setpwent(); +for (1..$max) { + my $pw = scalar getpwent(); + last unless defined $pw; + push @pw1, $pw; +} +endpwent(); + +my @pw2; + +setpwent(); +for (1..$max) { + my ($pw) = (getpwent()); + last unless defined $pw; + push @pw2, $pw; +} +endpwent(); + +print "not " unless "@pw1" eq "@pw2"; +print "ok ", $tst++, "\n"; + close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t index 60e5b7b..ea62ed8 100755 --- a/contrib/perl5/t/op/quotemeta.t +++ b/contrib/perl5/t/op/quotemeta.t @@ -2,18 +2,18 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..15\n"; +print "1..17\n"; if ($Config{ebcdic} eq 'define') { $_=join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes # 105 characters + 53 backslashes = 158 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} # 104 non-backslash characters if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} @@ -22,7 +22,7 @@ if ($Config{ebcdic} eq 'define') { # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes # 96 characters + 33 backslashes = 129 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} # 95 non-backslash characters if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} @@ -42,3 +42,6 @@ print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; + +print length(quotemeta("\x{263a}")) == 1 ? "ok 16\n" : "not ok 16\n"; +print quotemeta("\x{263a}") eq "\x{263a}" ? "ok 17\n" : "not ok 17\n"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t index 97019bb..83186ae 100755 --- a/contrib/perl5/t/op/rand.t +++ b/contrib/perl5/t/op/rand.t @@ -17,7 +17,7 @@ BEGIN { chdir "t" if -d "t"; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index d506e6e..6477d67 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -45,9 +45,9 @@ a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- -a[b-a] - c - /a[b-a]/: invalid [] range "b-a" in regexp -a[]b - c - /a[]b/: unmatched [] in regexp -a[ - c - /a[/: unmatched [] in regexp +a[b-a] - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / a] a] y $& a] a[]]b a]b y $& a]b a[^bc]d aed y $& aed @@ -95,21 +95,21 @@ a[\S]b a-b y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -*a - c - /*a/: ?+*{} follows nothing in regexp -(*)b - c - /(*)b/: ?+*{} follows nothing in regexp +*a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ $b b n - - a\ - c - Search pattern not terminated a\(b a(b y $&-$1 a(b- a\(*b ab y $& ab a\(*b a((b y $& a((b a\\b a\b y $& a\b -abc) - c - /abc)/: unmatched () in regexp -(abc - c - /(abc/: unmatched () in regexp +abc) - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ ((a)) abc y $&-$1-$2 a-a-a (a)b(c) abc y $&-$1-$2 abc-a-c a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc -a** - c - /a**/: nested *?+ in regexp +a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE / a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b){0,} ab y $&-$1 ab-b @@ -117,7 +117,7 @@ a.+?c abcabc y $& abc (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a -)( - c - /)(/: unmatched () in regexp +)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ [^ab]* cde y $& cde abc n - - a* y $& @@ -164,11 +164,11 @@ a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc a[-]?c ac y $& ac (abc)\1 abcabc y $1 abc ([a-c]*)\1 abcabc y $1 abc -\1 - c - /\1/: reference to nonexistent group -\2 - c - /\2/: reference to nonexistent group +\1 - c - Reference to nonexistent group +\2 - c - Reference to nonexistent group (a)|\1 a y - - (a)|\1 x n - - -(a)|\2 - c - /(a)|\2/: reference to nonexistent group +(a)|\2 - c - Reference to nonexistent group (([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b (([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c ((\3|b)\2(a)x)+ aaxabxbaxbbx n - - @@ -218,9 +218,9 @@ a[-]?c ac y $& ac 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- -'a[b-a]'i - c - /a[b-a]/: invalid [] range "b-a" in regexp -'a[]b'i - c - /a[]b/: unmatched [] in regexp -'a['i - c - /a[/: unmatched [] in regexp +'a[b-a]'i - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / 'a]'i A] y $& A] 'a[]]b'i A]B y $& A]B 'a[^bc]d'i AED y $& AED @@ -232,21 +232,21 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'*a'i - c - /*a/: ?+*{} follows nothing in regexp -'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp +'*a'i - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ '$b'i B n - - 'a\'i - c - Search pattern not terminated 'a\(b'i A(B y $&-$1 A(B- 'a\(*b'i AB y $& AB 'a\(*b'i A((B y $& A((B 'a\\b'i A\B y $& A\B -'abc)'i - c - /abc)/: unmatched () in regexp -'(abc'i - c - /(abc/: unmatched () in regexp +'abc)'i - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ '((a))'i ABC y $&-$1-$2 A-A-A '(a)b(c)'i ABC y $&-$1-$2 ABC-A-C 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - /a**/: nested *?+ in regexp +'a**'i - c - Nested quantifiers before HERE mark in regex m/a** << HERE / 'a.+?c'i ABCABC y $& ABC 'a.*?c'i ABCABC y $& ABC 'a.{0,5}?c'i ABCABC y $& ABC @@ -257,7 +257,7 @@ a[-]?c ac y $& ac '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A '(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - /)(/: unmatched () in regexp +')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -318,7 +318,7 @@ a(?:b|c|d){2}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d ((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar -:(?: - c - /(?/: Sequence (? incomplete +:(?: - c - Sequence (? incomplete a(?:b|c|d){6,7}(.) acdbcdbe y $1 e a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e a(?:b|c|d){5,6}(.) acdbcdbe y $1 e @@ -346,7 +346,7 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce (?<!c)b cb n - - (?<!c)b b y - - (?<!c)b b y $& b -(?<%)b - c - /(?<%)b/: Sequence (?%...) not recognized +(?<%)b - c - Sequence (?<%...) not recognized before HERE mark in regex m/(?<% << HERE )b/ (?:..)*a aba y $& aba (?:..)*?a aba y $& a ^(?:b|a(?=(.)))*\1 abc y $& ab @@ -397,10 +397,10 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce '(ab)\d\1'i ab4Ab y $1 ab foo\w*\d{4}baz foobar1234baz y $& foobar1234baz a(?{})b cabd y $& ab -a(?{)b - c - /a(?{)b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced -a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ +a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ +a(?{}})b - c - +a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ a(?{"\{"})b cabd y $& ab a(?{"{"}})b - c - Unmatched right curly bracket a(?{$bl="\{"}).b caxbd y $bl { @@ -441,8 +441,8 @@ x(~~)*(?:(?:F)?)? x~~ y - - ^(\(+)?blah(?(1)(\)))$ blah y ($2) () ^(\(+)?blah(?(1)(\)))$ blah) n - - ^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - /(?(1?)a|b)/: Switch (?(number? not recognized -(?(1)a|b|c) a c - /(?(1)a|b|c)/: Switch (?(condition)... contains too many branches +(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ +(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches (?(?{0})a|b) a n - - (?(?{0})b|a) a y $& a (?(?{1})b|a) a n - - @@ -473,10 +473,10 @@ $(?<=^(a)) a y $1 a ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp -[a[:xyz:] - c - Character class [:xyz:] unknown +[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ +[a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE / [a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - Character class [:xyz:] unknown +([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ [a[:]b[:c] abc y $& abc ([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd ([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy @@ -503,13 +503,13 @@ $(?<=^(a)) a y $1 a ([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} ([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 ([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} -[[:foo:]] - c - Character class [:foo:] unknown -[[:^foo:]] - c - Character class [:^foo:] unknown +[[:foo:]] - c - POSIX class [:foo:] unknown before HERE mark in regex m/[[:foo:] << HERE ]/ +[[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/ ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x -(?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented -a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +(?<=x+)y - c - Variable length lookbehind not implemented +a{37,17} - c - Can't do {n,m} with n > m \Z a\nb\n y $-[0] 3 \z a\nb\n y $-[0] 4 $ a\nb\n y $-[0] 3 @@ -750,3 +750,37 @@ tt+$ xxxtt y - - ^([a-z]:) C:/ n - - '^\S\s+aa$'m \nx aa y - - (^|a)b ab y - - +^([ab]*?)(b)?(c)$ abac y -$2- -- +(\w)?(abc)\1b abcab n - - +^(?:.,){2}c a,b,c y - - +^(.,){2}c a,b,c y $1 b, +^(?:[^,]*,){2}c a,b,c y - - +^([^,]*,){2}c a,b,c y $1 b, +^([^,]*,){3}d aaa,b,c,d y $1 c, +^([^,]*,){3,}d aaa,b,c,d y $1 c, +^([^,]*,){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, +(?i) y - - +'(?!\A)x'm a\nxb\n y - - +^(a(b)?)+$ aba y -$1-$2- -a-- +^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- +'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - +^(a)?a$ a y -$1- -- +^(a)?(?(1)a|b)+$ a n - - +^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa +^(a\1?){4}$ aaaaaa y $1 aa +^(0+)?(?:x(1))? x1 y - - +^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - +^(b+?|a){1,2}c bbbac y $1 a +^(b+?|a){1,2}c bbbbac y $1 a +\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- +((?:aaaa|bbbb)cccc)? aaaacccc y - - +((?:aaaa|bbbb)cccc)? bbbbcccc y - - diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t index d101c2f..00199b0 100755 --- a/contrib/perl5/t/op/readdir.t +++ b/contrib/perl5/t/op/readdir.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } eval 'opendir(NOSUCH, "no/such/directory");'; @@ -20,7 +20,11 @@ if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); -if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } +## +## This range will have to adjust as the number of tests expands, +## as it's counting the number of .t files in src/t +## +if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; } @R = sort @D; @G = sort <op/*.t>; diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t index 4ffe136..4a4d42f 100755 --- a/contrib/perl5/t/op/regexp.t +++ b/contrib/perl5/t/op/regexp.t @@ -1,8 +1,5 @@ #!./perl -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - # The tests are in a separate file 't/op/re_tests'. # Each line in that file is a separate test. # There are five columns, separated by tabs. @@ -26,6 +23,9 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # +# Column 6, if present, contains a reason why the test is skipped. +# This is printed with "skipped", for harness to pick up. +# # \n in the tests are interpolated, as are variables of the form ${\w+}. # # If you want to add a regular expression test that can't be expressed @@ -33,7 +33,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } $iters = shift || 1; # Poor man performance suite, 10000 is OK. @@ -56,7 +56,7 @@ TEST: while (<TESTS>) { chomp; s/\\n/\n/g; - ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); + ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); $input = join(':',$pat,$subject,$result,$repl,$expect); infty_subst(\$pat); infty_subst(\$expect); @@ -70,7 +70,8 @@ while (<TESTS>) { $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); # Certain tests don't work with utf8 (the re_test should be in UTF8) - $skip = 1 if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word):\]/; + $skip = 1, $reason = 'utf8' + if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/; $result =~ s/B//i unless $skip; for $study ('', 'study \$subject') { $c = $iters; @@ -81,7 +82,8 @@ while (<TESTS>) { last; # no need to study a syntax error } elsif ( $skip ) { - print "ok $. # skipped\n"; next TEST; + print "ok $. # skipped", length($reason) ? " $reason" : '', "\n"; + next TEST; } elsif ($@) { print "not ok $. $input => error `$err'\n"; next TEST; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index e988ad9..b6c128b 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -7,7 +7,7 @@ ## chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; @@ -349,3 +349,18 @@ A 1 bar B 2 bar +######## +sub n { 0 } +sub f { my $x = shift; d(); } +f(n()); +f(); + +sub d { + my $i = 0; my @a; + while (do { { package DB; @a = caller($i++) } } ) { + @a = @DB::args; + for (@a) { print "$_\n"; $_ = '' } + } +} +EXPECT +0 diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index ba0a4c2..29aff1d 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -2,16 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..49\n"; - -# XXX known to leak scalars -{ - no warnings 'uninitialized'; - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} +print "1..57\n"; # these shouldn't hang { @@ -270,3 +264,54 @@ 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"; + +# check if context for sort arguments is handled right + +$test = 49; +sub test_if_list { + my $gimme = wantarray; + print "not " unless $gimme; + ++$test; + print "ok $test\n"; +} +my $m = sub { $a <=> $b }; + +sub cxt_one { sort $m test_if_list() } +cxt_one(); +sub cxt_two { sort { $a <=> $b } test_if_list() } +cxt_two(); +sub cxt_three { sort &test_if_list() } +cxt_three(); + +sub test_if_scalar { + my $gimme = wantarray; + print "not " if $gimme or !defined($gimme); + ++$test; + print "ok $test\n"; +} + +$m = \&test_if_scalar; +sub cxt_four { sort $m 1,2 } +@x = cxt_four(); +sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } +@x = cxt_five(); +sub cxt_six { sort test_if_scalar 1,2 } +@x = cxt_six(); + +# test against a reentrancy bug +{ + package Bar; + sub compare { $a cmp $b } + sub reenter { my @force = sort compare qw/a b/ } +} +{ + my($def, $init) = (0, 0); + @b = sort { + $def = 1 if defined $Bar::a; + Bar::reenter() unless $init++; + $a <=> $b + } qw/4 3 1 2/; + print ("@b" eq '1 2 3 4' ? "ok 56\n" : "not ok 56\n"); + print "# x = '@b'\n"; + print !$def ? "ok 57\n" : "not ok 57\n"; +} diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t index 8b9f4ad..9a6586d 100755 --- a/contrib/perl5/t/op/split.t +++ b/contrib/perl5/t/op/split.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ - -print "1..25\n"; +print "1..29\n"; $FS = ':'; @@ -109,3 +107,23 @@ print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; $_ = "a : b :c: d"; @ary = split(/\s*:\s*/); if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} + +# use of match result as pattern (!) +'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; +print "ok 26\n"; + +# /^/ treated as /^/m +$_ = join ':', split /^/, "ab\ncd\nef\n"; +print "not " if $_ ne "ab\n:cd\n:ef\n"; +print "ok 27\n"; + +# see if @a = @b = split(...) optimization works +@list1 = @list2 = split ('p',"a p b c p"); +print "not " if @list1 != @list2 or "@list1" ne "@list2" + or @list1 != 2 or "@list1" ne "a b c "; +print "ok 28\n"; + +# zero-width assertion +$_ = join ':', split /(?=\w)/, "rm b"; +print "not" if $_ ne "r:m :b"; +print "ok 29\n"; diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t index 4d54d2c..f4af3cd 100755 --- a/contrib/perl5/t/op/sprintf.t +++ b/contrib/perl5/t/op/sprintf.t @@ -1,38 +1,310 @@ #!./perl -# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +# Tests sprintf, excluding handling of 64-bit integers or long +# doubles (if supported), of machine-specific short and long +# integers, machine-specific floating point exceptions (infinity, +# not-a-number ...), of the effects of locale, and of features +# specific to multi-byte characters (under use utf8 and such). BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..4\n"; +while (<DATA>) { + s/^\s*>//; s/<\s*$//; + push @tests, [split(/<\s*>/, $_, 4)]; +} + +print '1..', scalar @tests, "\n"; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { - $w++; + $w = ' INVALID' } else { warn @_; } }; -$w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171); -if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) { - print "ok 1\n"; -} else { - print "not ok 1 '$x'\n"; -} +for ($i = 1; @tests; $i++) { + ($template, $data, $result, $comment) = @{shift @tests}; + $evalData = eval $data; + $w = undef; + $x = sprintf(">$template<", + defined @$evalData ? @$evalData : $evalData); + substr($x, -1, 0) = $w if $w; + # $x may have 3 exponent digits, not 2 + my $y = $x; + if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { + # if result is left-adjusted, append extra space + if ($template =~ /%\+?\-/ and $result =~ / $/) { + $y =~ s/<$/ </; + } + # if result is zero-filled, add extra zero + elsif ($template =~ /%\+?0/ and $result =~ /^0/) { + $y =~ s/^>0/>00/; + } + # if result is right-adjusted, prepend extra space + elsif ($result =~ /^ /) { + $y =~ s/^>/> /; + } + } -for $i (2 .. 4) { - $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; - $w = 0; - $x = sprintf($f, ''); - if ($x eq $f && $w == 1) { - print "ok $i\n"; - } else { - print "not ok $i '$x' '$f' '$w'\n"; + if ($x eq ">$result<") { + print "ok $i\n"; + } + elsif ($y eq ">$result<") # Some C libraries always give + { # three-digit exponent + print("ok $i # >$result< $x three-digit exponent accepted\n"); + } + elsif ($result =~ /[-+]\d{3}$/ && + # Suppress tests with modulo of exponent >= 100 on platforms + # which can't handle such magnitudes (or where we can't tell). + ((!eval {require POSIX}) || # Costly: only do this if we must! + (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) + { + print("ok $i # >$template< >$data< >$result<", + " Suppressed: exponent out of range?\n") + } + else { + $y = ($x eq $y ? "" : " => $y"); + print("not ok $i >$template< >$data< >$result< $x$y", + $comment ? " # $comment\n" : "\n"); } } + +# In each of the the following lines, there are three required fields: +# printf template, data to be formatted (as a Perl expression), and +# expected result of formatting. An optional fourth field can contain +# a comment. Each field is delimited by a starting '>' and a +# finishing '<'; any whitespace outside these start and end marks is +# not part of the field. If formatting requires more than one data +# item (for example, if variable field widths are used), the Perl data +# expression should return a reference to an array having the requisite +# number of elements. Even so, subterfuge is sometimes required: see +# tests for %n and %p. +# +# The following tests are not currently run, for the reasons stated: + +=pod + +=begin problematic + +>%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX< +>%.0f< >1.5< >2< >Standard vague: no rounding rules< +>%.0f< >2.5< >2< >Standard vague: no rounding rules< + +=end problematic + +=cut + +# template data result +__END__ +>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< +>%6 .6s< >''< >%6 .6s INVALID< +>%6.6 s< >''< >%6.6 s INVALID< +>%A< >''< >%A INVALID< +>%B< >''< >%B INVALID< +>%C< >''< >%C INVALID< +>%D< >0x7fffffff< >2147483647< >Synonym for %ld< +>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< +>%F< >123456.789< >123456.789000< >Synonym for %f< +>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< +>%G< >1234567e96< >1.23457E+102< +>%G< >.1234567e-101< >1.23457E-102< +>%G< >12345.6789< >12345.7< +>%H< >''< >%H INVALID< +>%I< >''< >%I INVALID< +>%J< >''< >%J INVALID< +>%K< >''< >%K INVALID< +>%L< >''< >%L INVALID< +>%M< >''< >%M INVALID< +>%N< >''< >%N INVALID< +>%O< >2**32-1< >37777777777< >Synonum for %lo< +>%P< >''< >%P INVALID< +>%Q< >''< >%Q INVALID< +>%R< >''< >%R INVALID< +>%S< >''< >%S INVALID< +>%T< >''< >%T INVALID< +>%U< >2**32-1< >4294967295< >Synonum for %lu< +>%V< >''< >%V INVALID< +>%W< >''< >%W INVALID< +>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< +>%#X< >2**32-1< >0XFFFFFFFF< +>%Y< >''< >%Y INVALID< +>%Z< >''< >%Z INVALID< +>%a< >''< >%a INVALID< +>%b< >2**32-1< >11111111111111111111111111111111< +>%+b< >2**32-1< >11111111111111111111111111111111< +>%#b< >2**32-1< >0b11111111111111111111111111111111< +>%34b< >2**32-1< > 11111111111111111111111111111111< +>%034b< >2**32-1< >0011111111111111111111111111111111< +>%-34b< >2**32-1< >11111111111111111111111111111111 < +>%-034b< >2**32-1< >11111111111111111111111111111111 < +>%c< >ord('A')< >A< +>%10c< >ord('A')< > A< +>%#10c< >ord('A')< > A< ># modifier: no effect< +>%010c< >ord('A')< >000000000A< +>%10lc< >ord('A')< > A< >l modifier: no effect< +>%10hc< >ord('A')< > A< >h modifier: no effect< +>%10.5c< >ord('A')< > A< >precision: no effect< +>%-10c< >ord('A')< >A < +>%d< >123456.789< >123456< +>%d< >-123456.789< >-123456< +>%d< >0< >0< +>%+d< >0< >+0< +>%0d< >0< >0< +>%.0d< >0< >< +>%+.0d< >0< >+< +>%.0d< >1< >1< +>%d< >1< >1< +>%+d< >1< >+1< +>%#3.2d< >1< > 01< ># modifier: no effect< +>%3.2d< >1< > 01< +>%03.2d< >1< >001< +>%-3.2d< >1< >01 < +>%-03.2d< >1< >01 < >zero pad + left just.: no effect< +>%d< >-1< >-1< +>%+d< >-1< >-1< +>%hd< >1< >1< >More extensive testing of< +>%ld< >1< >1< >length modifiers would be< +>%Vd< >1< >1< >platform-specific< +>%vd< >chr(1)< >1< +>%+vd< >chr(1)< >+1< +>%#vd< >chr(1)< >1< +>%vd< >"\01\02\03"< >1.2.3< +>%v.3d< >"\01\02\03"< >001.002.003< +>%v03d< >"\01\02\03"< >001.002.003< +>%v-3d< >"\01\02\03"< >1 .2 .3 < +>%v+-3d< >"\01\02\03"< >+1 .2 .3 < +>%v4.3d< >"\01\02\03"< > 001. 002. 003< +>%v04.3d< >"\01\02\03"< >0001.0002.0003< +>%*v02d< >['-', "\0\7\14"]< >00-07-12< +>%v.*d< >[3, "\01\02\03"]< >001.002.003< +>%v0*d< >[3, "\01\02\03"]< >001.002.003< +>%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < +>%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < +>%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< +>%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< +>%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11< +>%e< >1234.875< >1.234875e+03< +>%e< >0.000012345< >1.234500e-05< +>%e< >1234567E96< >1.234567e+102< +>%e< >0< >0.000000e+00< +>%e< >.1234567E-101< >1.234567e-102< +>%+e< >1234.875< >+1.234875e+03< +>%#e< >1234.875< >1.234875e+03< +>%e< >-1234.875< >-1.234875e+03< +>%+e< >-1234.875< >-1.234875e+03< +>%#e< >-1234.875< >-1.234875e+03< +>%.0e< >1234.875< >1e+03< +>%#.0e< >1234.875< >1.e+03< +>%.*e< >[0, 1234.875]< >1e+03< +>%.1e< >1234.875< >1.2e+03< +>%-12.4e< >1234.875< >1.2349e+03 < +>%12.4e< >1234.875< > 1.2349e+03< +>%+-12.4e< >1234.875< >+1.2349e+03 < +>%+12.4e< >1234.875< > +1.2349e+03< +>%+-12.4e< >-1234.875< >-1.2349e+03 < +>%+12.4e< >-1234.875< > -1.2349e+03< +>%f< >1234.875< >1234.875000< +>%+f< >1234.875< >+1234.875000< +>%#f< >1234.875< >1234.875000< +>%f< >-1234.875< >-1234.875000< +>%+f< >-1234.875< >-1234.875000< +>%#f< >-1234.875< >-1234.875000< +>%6f< >1234.875< >1234.875000< +>%*f< >[6, 1234.875]< >1234.875000< +>%.0f< >1234.875< >1235< +>%.1f< >1234.875< >1234.9< +>%-8.1f< >1234.875< >1234.9 < +>%8.1f< >1234.875< > 1234.9< +>%+-8.1f< >1234.875< >+1234.9 < +>%+8.1f< >1234.875< > +1234.9< +>%+-8.1f< >-1234.875< >-1234.9 < +>%+8.1f< >-1234.875< > -1234.9< +>%*.*f< >[5, 2, 12.3456]< >12.35< +>%f< >0< >0.000000< +>%.0f< >0< >0< +>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< +>%.0f< >0.1< >0< +>%.0f< >0.6< >1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >1< >1< +>%#.0f< >1< >1.< +>%g< >12345.6789< >12345.7< +>%+g< >12345.6789< >+12345.7< +>%#g< >12345.6789< >12345.7< +>%.0g< >12345.6789< >1e+04< +>%#.0g< >12345.6789< >1.e+04< +>%.2g< >12345.6789< >1.2e+04< +>%.*g< >[2, 12345.6789]< >1.2e+04< +>%.9g< >12345.6789< >12345.6789< +>%12.9g< >12345.6789< > 12345.6789< +>%012.9g< >12345.6789< >0012345.6789< +>%-12.9g< >12345.6789< >12345.6789 < +>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < +>%-012.9g< >12345.6789< >12345.6789 < +>%g< >-12345.6789< >-12345.7< +>%+g< >-12345.6789< >-12345.7< +>%g< >1234567.89< >1.23457e+06< +>%+g< >1234567.89< >+1.23457e+06< +>%#g< >1234567.89< >1.23457e+06< +>%g< >-1234567.89< >-1.23457e+06< +>%+g< >-1234567.89< >-1.23457e+06< +>%#g< >-1234567.89< >-1.23457e+06< +>%g< >0.00012345< >0.00012345< +>%g< >0.000012345< >1.2345e-05< +>%g< >1234567E96< >1.23457e+102< +>%g< >.1234567E-101< >1.23457e-102< +>%g< >0< >0< +>%13g< >1234567.89< > 1.23457e+06< +>%+13g< >1234567.89< > +1.23457e+06< +>%013g< >1234567.89< >001.23457e+06< +>%-13g< >1234567.89< >1.23457e+06 < +>%h< >''< >%h INVALID< +>%i< >123456.789< >123456< >Synonym for %d< +>%j< >''< >%j INVALID< +>%k< >''< >%k INVALID< +>%l< >''< >%l INVALID< +>%m< >''< >%m INVALID< +>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< +>%o< >2**32-1< >37777777777< +>%+o< >2**32-1< >37777777777< +>%#o< >2**32-1< >037777777777< +>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< +>%#p< >''< >%#p INVALID< +>%q< >''< >%q INVALID< +>%r< >''< >%r INVALID< +>%s< >'string'< >string< +>%10s< >'string'< > string< +>%+10s< >'string'< > string< +>%#10s< >'string'< > string< +>%010s< >'string'< >0000string< +>%0*s< >[10, 'string']< >0000string< +>%-10s< >'string'< >string < +>%3s< >'string'< >string< +>%.3s< >'string'< >str< +>%.*s< >[3, 'string']< >str< +>%t< >''< >%t INVALID< +>%u< >2**32-1< >4294967295< +>%+u< >2**32-1< >4294967295< +>%#u< >2**32-1< >4294967295< +>%12u< >2**32-1< > 4294967295< +>%012u< >2**32-1< >004294967295< +>%-12u< >2**32-1< >4294967295 < +>%-012u< >2**32-1< >4294967295 < +>%v< >''< >%v INVALID< +>%w< >''< >%w INVALID< +>%x< >2**32-1< >ffffffff< +>%+x< >2**32-1< >ffffffff< +>%#x< >2**32-1< >0xffffffff< +>%10x< >2**32-1< > ffffffff< +>%010x< >2**32-1< >00ffffffff< +>%-10x< >2**32-1< >ffffffff < +>%-010x< >2**32-1< >ffffffff < +>%0-10x< >2**32-1< >ffffffff < +>%0*x< >[-10, ,2**32-1]< >ffffffff < +>%y< >''< >%y INVALID< +>%z< >''< >%z INVALID< diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t index af4920c..1d8c7a3 100755 --- a/contrib/perl5/t/op/stat.t +++ b/contrib/perl5/t/op/stat.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -32,7 +32,7 @@ if (open(FOO, ">Op.stat.tmp")) { else { print "# res=$res, nlink=$nlink.\nnot ok 1\n"; } - if ($Is_MSWin32 or $Is_Cygwin || ($mtime && $mtime == $ctime)) { + if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) { print "ok 2\n"; } else { @@ -80,6 +80,7 @@ else { print "not ok 4\n"; print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; + print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; } print "#4 :$mtime: should != :$ctime:\n"; @@ -177,14 +178,18 @@ if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { $cnt = $uid = 0; die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin)) - or print ("not ok 35\n"), goto tty_test; -opendir BIN, $bin or die "Can't opendir $bin: $!"; -while (defined($_ = readdir BIN)) { - $_ = "$bin/$_"; - $cnt++; - $uid++ if -u; - last if $uid && $uid < $cnt; +my @bin = grep {-d} ($^O eq 'machten' ? + qw(/usr/bin /bin) : + qw(/sbin /usr/sbin /bin /usr/bin)); +unless (@bin) { print ("not ok 35\n"), goto tty_test; } +for my $bin (@bin) { + opendir BIN, $bin or die "Can't opendir $bin: $!"; + while (defined($_ = readdir BIN)) { + $_ = "$bin/$_"; + $cnt++; + $uid++ if -u; + last if $uid && $uid < $cnt; + } } closedir BIN; diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t index 9757f4c..7dd7a1c 100755 --- a/contrib/perl5/t/op/subst.t +++ b/contrib/perl5/t/op/subst.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t index e2e7c0e5..7189572 100755 --- a/contrib/perl5/t/op/subst_amp.t +++ b/contrib/perl5/t/op/subst_amp.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t index 5764e67..85574d5 100755 --- a/contrib/perl5/t/op/substr.t +++ b/contrib/perl5/t/op/substr.t @@ -1,10 +1,12 @@ +#!./perl -print "1..125\n"; +print "1..174\n"; #P = start of string Q = start of substr R = end of substr S = end of string BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + chdir 't' if -d 't'; + @INC = '../lib'; } use warnings ; @@ -268,3 +270,318 @@ ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; $a = "abcdefgh"; ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; ok 125, $a eq 'xxxxefgh'; + +{ + my $y = 10; + $y = "2" . $y; + ok 126, $y+0 == 210; +} + +# utf8 sanity +{ + my $x = substr("a\x{263a}b",0); + ok 127, length($x) == 3; + $x = substr($x,1,1); + ok 128, $x eq "\x{263a}"; + $x = $x x 2; + ok 129, length($x) == 2; + substr($x,0,1) = "abcd"; + ok 130, $x eq "abcd\x{263a}"; + ok 131, length($x) == 5; + $x = reverse $x; + ok 132, length($x) == 5; + ok 133, $x eq "\x{263a}dcba"; + + my $z = 10; + $z = "21\x{263a}" . $z; + ok 134, length($z) == 5; + ok 135, $z eq "21\x{263a}10"; +} + +# replacement should work on magical values +require Tie::Scalar; +my %data; +tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical +$data{a} = "firstlast"; +ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last"; + +# more utf8 + +# The following two originally from Ignasi Roca. + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} +ok 137, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} +ok 138, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +# more utf8 lval exercise + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 139, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 140, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 141, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 142, length($x) == 5 && + $x eq "\xF1\xF2\xF3\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 143, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 144, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 145, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 146, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 147, length($x) == 5 && + $x eq "\x{100}\xFF\xF1\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F1}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 148, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 149, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +# And tests for already-UTF8 one + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}"; +ok 150, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}\x{FF}"; +ok 151, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 152, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 153, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 154, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 155, length($x) == 5 && + $x eq "\x{101}\x{F2}\x{F3}\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 156, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 157, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 158, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 159, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 160, length($x) == 5 && + $x eq "\x{100}\xFF\x{101}\x{F2}\x{F3}" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{101}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 161, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 162, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +substr($x = "ab", 0, 0, "\x{100}\x{200}"); +ok 163, $x eq "\x{100}\x{200}ab"; + +substr($x = "\x{100}\x{200}", 0, 0, "ab"); +ok 164, $x eq "ab\x{100}\x{200}"; + +substr($x = "ab", 1, 0, "\x{100}\x{200}"); +ok 165, $x eq "a\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "ab"); +ok 166, $x eq "\x{100}ab\x{200}"; + +substr($x = "ab", 2, 0, "\x{100}\x{200}"); +ok 167, $x eq "ab\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "ab"); +ok 168, $x eq "\x{100}\x{200}ab"; + +substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); +ok 169, $x eq "\x{100}\x{200}\xFFb"; + +substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); +ok 170, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); +ok 171, $x eq "\xFF\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); +ok 172, $x eq "\x{100}\xFFb\x{200}"; + +substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); +ok 173, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); +ok 174, $x eq "\x{100}\x{200}\xFFb"; + diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index 6548b46..2958a37 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use strict; @@ -19,14 +19,20 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +use vars qw($ipcsysv); # did we manage to load IPC::SysV? + BEGIN { if ($^O eq 'VMS' && !defined($Config{d_setenv})) { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } - if ($Config{d_shm} || $Config{d_msg}) { - require IPC::SysV; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ + && ($Config{d_shm} || $Config{d_msg})) { + eval { require IPC::SysV }; + unless ($@) { + $ipcsysv++; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } } } @@ -98,7 +104,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..151\n"; +print "1..155\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -612,13 +618,17 @@ else { # test shmread { - if ($Config{d_shm}) { + unless ($ipcsysv) { + print "ok 150 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || - warn "# shmget failed: $!\n"; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); + if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { @@ -629,7 +639,7 @@ else { } else { warn "# shmwrite failed: $!\n"; } - shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } @@ -646,7 +656,11 @@ else { # test msgrcv { - if ($Config{d_msg}) { + unless ($ipcsysv) { + print "ok 151 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); @@ -665,7 +679,7 @@ else { } else { warn "# msgsnd failed\n"; } - msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } @@ -680,3 +694,42 @@ else { } } +{ + # bug id 20001004.006 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + local $/; + my $a = <IN>; + my $b = <IN>; + print "not " unless tainted($a) && tainted($b) && !defined($b); + print "ok 152\n"; + close IN; +} + +{ + # bug id 20001004.007 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + my $a = <IN>; + + my $c = { a => 42, + b => $a }; + print "not " unless !tainted($c->{a}) && tainted($c->{b}); + print "ok 153\n"; + + my $d = { a => $a, + b => 42 }; + print "not " unless tainted($d->{a}) && !tainted($d->{b}); + print "ok 154\n"; + + my $e = { a => 42, + b => { c => $a, d => 42 } }; + print "not " unless !tainted($e->{a}) && + !tainted($e->{b}) && + tainted($e->{b}->{c}) && + !tainted($e->{b}->{d}); + print "ok 155\n"; + + close IN; +} + diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 9543420..cbf92c6 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -6,7 +6,7 @@ # Currently it only tests the untie warning chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -44,6 +44,21 @@ untie %h; EXPECT ######## +# standard behaviour, without any extra references +use Tie::Hash ; +{package Tie::HashUntie; + use base 'Tie::StdHash'; + sub UNTIE + { + warn "Untied\n"; + } +} +tie %h, Tie::HashUntie; +untie %h; +EXPECT +Untied +######## + # standard behaviour, with 1 extra reference use Tie::Hash ; $a = tie %h, Tie::StdHash; diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t index 25fda3f..8e78b2f 100755 --- a/contrib/perl5/t/op/tiearray.t +++ b/contrib/perl5/t/op/tiearray.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } my %seen; diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index 6ae3faa..b04bdb7 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } my @expect; @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..29\n"; +print "1..33\n"; my $fh = gensym; @@ -149,3 +149,19 @@ ok($data eq "qwerty"); @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); + +# Does aliasing work with tied FHs? +*ALIAS = *$fh; +@expect = (PRINT => $ob,"some","text"); +$r = print ALIAS @expect[2,3]; +ok($r == 1); + +{ + use warnings; + # Special case of aliasing STDERR, which used + # to dump core when warnings were enabled + *STDERR = *$fh; + @expect = (PRINT => $ob,"some","text"); + $r = print STDERR @expect[2,3]; + ok($r == 1); +} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t index 4e6667c..c7ba0d8 100755 --- a/contrib/perl5/t/op/tr.t +++ b/contrib/perl5/t/op/tr.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..4\n"; +print "1..54\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -37,3 +37,275 @@ print "ok 3\n"; print "ok 4\n"; } # + +# make sure that tr cancels IOK and NOK +($x = 12) =~ tr/1/3/; +(my $y = 12) =~ tr/1/3/; +($f = 1.5) =~ tr/1/3/; +(my $g = 1.5) =~ tr/1/3/; +print "not " unless $x + $y + $f + $g == 71; +print "ok 5\n"; + +# make sure tr is harmless if not updating - see [ID 20000511.005] +$_ = 'fred'; +/([a-z]{2})/; +$1 =~ tr/A-Z//; +s/^(\s*)f/$1F/; +print "not " if $_ ne 'Fred'; +print "ok 6\n"; + +# check tr handles UTF8 correctly +($x = 256.65.258) =~ tr/a/b/; +print "not " if $x ne 256.65.258 or length $x != 3; +print "ok 7\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.66.258 or length $x != 3; +} +else { + print "not " if $x ne 256.65.258 or length $x != 3; +} +print "ok 8\n"; +# EBCDIC variants of the above tests +($x = 256.193.258) =~ tr/a/b/; +print "not " if $x ne 256.193.258 or length $x != 3; +print "ok 9\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.193.258 or length $x != 3; +} +else { + print "not " if $x ne 256.194.258 or length $x != 3; +} +print "ok 10\n"; + +{ +if (ord("\t") == 9) { # ASCII + use utf8; +} +# 11 - changing UTF8 characters in a UTF8 string, same length. +$l = chr(300); $r = chr(400); +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{190}/; +printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; +print "ok 11\n"; + +# 12 - changing UTF8 characters in UTF8 string, more bytes. +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{be8}/; +printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; +print "ok 12\n"; + +# 13 - introducing UTF8 characters to non-UTF8 string. +$x = 100.125.60; +$x =~ tr/\x{64}/\x{190}/; +printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; +print "ok 13\n"; + +# 14 - removing UTF8 characters from UTF8 string +$x = 400.125.60; +$x =~ tr/\x{190}/\x{64}/; +printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; +print "ok 14\n"; + +# 15 - counting UTF8 chars in UTF8 string +$x = 400.125.60.400; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 2; +print "ok 15\n"; + +# 16 - counting non-UTF8 chars in UTF8 string +$x = 60.400.125.60.400; +$y = $x =~ tr/\x{3c}/\x{3c}/; +print "not " if $y != 2; +print "ok 16\n"; + +# 17 - counting UTF8 chars in non-UTF8 string +$x = 200.125.60; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 0; +print "ok 17\n"; +} + +# 18: test brokenness with tr/a-z-9//; +$_ = "abcdefghijklmnopqrstuvwxyz"; +eval "tr/a-z-9/ /"; +print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 18\n"); + +# 19-21: Make sure leading and trailing hyphens still work +$_ = "car-rot9"; +tr/-a-m/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); + +$_ = "car-rot9"; +tr/a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n"); + +$_ = "car-rot9"; +tr/-a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n"); + +$_ = "abcdefghijklmnop"; +tr/ae-hn/./; +print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n"); + +$_ = "abcdefghijklmnop"; +tr/a-cf-kn-p/./; +print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n"); + +$_ = "abcdefghijklmnop"; +tr/a-ceg-ikm-o/./; +print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n"); + +# 25: Test reversed range check +# 20000705 MJD +eval "tr/m-d/ /"; +print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 25\n"); + +# 26: test cannot update if read-only +eval '$1 =~ tr/x/y/'; +print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', + "ok 26\n"); + +# 27: test can count read-only +'abcdef' =~ /(bcd)/; +print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n"); + +# 28: test lhs OK if not updating +print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n"); + +# 29: test lhs bad if updating +eval '"123" =~ tr/1/1/'; +print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) + ? '' : 'not ', "ok 29\n"); + +# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) +# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) + +# Transliterate a byte to a byte, all four ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 30\n"; + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 31\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 32\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 33\n"; + +# Transliterate a byte to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; +print "not " unless $a eq v300.301.172.300.301.172; +print "ok 34\n"; + +# Transliterate a wide character to a byte. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; +print "not " unless $a eq v195.196.172.195.196.172; +print "ok 35\n"; + +# Transliterate a wide character to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; +print "not " unless $a eq v301.196.172.301.196.172; +print "ok 36\n"; + +# Transliterate both ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; +print "not " unless $a eq v195.301.172.195.301.172; +print "ok 37\n"; + +# Transliterate all (four) ways. + +($a = v300.196.172.300.196.172.400.198.144) =~ + tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; +print "not " unless $a eq v197.301.173.197.301.173.401.198.144; +print "ok 38\n"; + +# Transliterate and count. + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2; +print "ok 39\n"; + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2; +print "ok 40\n"; + +# Transliterate with complement. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; +print "not " unless $a eq v301.196.301.301.196.301; +print "ok 41\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; +print "not " unless $a eq v300.197.197.300.197.197; +print "ok 42\n"; + +# Transliterate with deletion. + +($a = v300.196.172.300.196.172) =~ tr/\xc4//d; +print "not " unless $a eq v300.172.300.172; +print "ok 43\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; +print "not " unless $a eq v196.172.196.172; +print "ok 44\n"; + +# Transliterate with squeeze. + +($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; +print "not " unless $a eq v197.172.300.300.197.172; +print "ok 45\n"; + +($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; +print "not " unless $a eq v196.172.301.196.172.172; +print "ok 46\n"; + +# Tricky cases by Simon Cozens. + +($a = v196.172.200) =~ tr/\x{12c}/a/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 47\n"; + +($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 48\n"; + +($a = v196.172.200) =~ tr/\x{12c}//d; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 49\n"; + +# UTF8 range + +($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; +print "not " unless $a eq v192.196.172.194.197.172; +print "ok 50\n"; + +($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; +print "not " unless $a eq v300.300.172.302.301.172; +print "ok 51\n"; + +# misc +($a = "R0_001") =~ tr/R_//d; +print "not " if hex($a) != 1; +print "ok 52\n"; + +@a = (1,2); map { y/1/./ for $_ } @a; +print "not " if "@a" ne ". 2"; +print "ok 53\n"; + +@a = (1,2); map { y/1/./ for $_.'' } @a; +print "not " if "@a" ne "1 2"; +print "ok 54\n"; diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 8944ee3..f6e36a5 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..27\n"; diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t index a6bd03d..e6db8e6 100755 --- a/contrib/perl5/t/op/universal.t +++ b/contrib/perl5/t/op/universal.t @@ -5,10 +5,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + $| = 1; } -print "1..73\n"; +print "1..80\n"; $a = {}; bless $a, "Bob"; @@ -28,6 +29,19 @@ sub new { bless {} } $Alice::VERSION = 2.718; +{ + package Cedric; + our @ISA; + use base qw(Human); +} + +{ + package Programmer; + our $VERSION = 1.667; + + sub write_perl { 1 } +} + package main; my $i = 2; @@ -45,12 +59,34 @@ test $a->isa("Human"); test ! $a->isa("Male"); +test ! $a->isa('Programmer'); + test $a->can("drink"); test $a->can("eat"); test ! $a->can("sleep"); +test (!Cedric->isa('Programmer')); + +test (Cedric->isa('Human')); + +push(@Cedric::ISA,'Programmer'); + +test (Cedric->isa('Programmer')); + +{ + package Alice; + base::->import('Programmer'); +} + +test $a->isa('Programmer'); +test $a->isa("Female"); + +@Cedric::ISA = qw(Bob); + +test (!Cedric->isa('Programmer')); + my $b = 'abc'; my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); @@ -88,7 +124,7 @@ eval "use UNIVERSAL"; test $a->isa("UNIVERSAL"); -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug if ('a' lt 'A') { test $sub2 eq "can import isa VERSION"; diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t index bf60fc4..7fe0974 100755 --- a/contrib/perl5/t/op/vec.t +++ b/contrib/perl5/t/op/vec.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ - -print "1..15\n"; +print "1..30\n"; print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; @@ -25,3 +23,58 @@ vec($Vec, 0, 32) = 0xbaddacab; print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; +# ensure vec() handles numericalness correctly +$foo = $bar = $baz = 0; +vec($foo = 0,0,1) = 1; +vec($bar = 0,1,1) = 1; +$baz = $foo | $bar; +print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; +print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; +print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; + +# error cases + +$x = eval { vec $foo, 0, 3 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 19\n"; +$x = eval { vec $foo, 0, 0 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 20\n"; +$x = eval { vec $foo, 0, -13 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 21\n"; +$x = eval { vec($foo, -1, 4) = 2 }; +print "not " if defined $x or $@ !~ /^Assigning to negative offset in vec/; +print "ok 22\n"; +print "not " if vec('abcd', 7, 8); +print "ok 23\n"; + +# UTF8 +# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling + +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +print "not " if vec($x, 0, 8) != 255; +print "ok 24\n"; +eval { vec($foo, 1, 8) }; +print "not " if $@; +print "ok 25\n"; +eval { vec($foo, 1, 8) = 13 }; +print "not " if $@; +print "ok 26\n"; +print "not " if $foo ne "\xc4\x0d\xc3\xbf\xc3\xbe"; +print "ok 27\n"; +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +vec($x, 2, 4) = 7; +print "not " if $x ne "\xff\xf7"; +print "ok 28\n"; + +# mixed magic + +$foo = "\x61\x62\x63\x64\x65\x66"; +print "not " if vec(substr($foo, 2, 2), 0, 16) != 25444; +print "ok 29\n"; +vec(substr($foo, 1,3), 5, 4) = 3; +print "not " if $foo ne "\x61\x62\x63\x34\x65\x66"; +print "ok 30\n"; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t index b08849f..edfebd2 100755 --- a/contrib/perl5/t/op/ver.t +++ b/contrib/perl5/t/op/ver.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..22\n"; +print "1..28\n"; my $test = 1; @@ -14,13 +14,24 @@ require v5.5.640; print "ok $test\n"; ++$test; # printing characters should work -print v111; -print v107.32; -print "$test\n"; ++$test; - -# hash keys too -$h{v111.107} = "ok"; -print "$h{ok} $test\n"; ++$test; +if (ord("\t") == 9) { # ASCII + print v111; + print v107.32; + print "$test\n"; ++$test; + + # hash keys too + $h{v111.107} = "ok"; + print "$h{ok} $test\n"; ++$test; +} +else { # EBCDIC + print v150; + print v146.64; + print "$test\n"; ++$test; + + # hash keys too + $h{v150.146} = "ok"; + print "$h{ok} $test\n"; ++$test; +} # poetry optimization should also sub v77 { "ok" } @@ -28,7 +39,12 @@ $x = v77; print "$x $test\n"; ++$test; # but not when dots are involved -$x = v77.78.79; +if (ord("\t") == 9) { # ASCII + $x = v77.78.79; +} +else { + $x = v212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -42,10 +58,20 @@ require 5.5.640; print "ok $test\n"; ++$test; # hash keys too -$h{111.107.32} = "ok"; +if (ord("\t") == 9) { # ASCII + $h{111.107.32} = "ok"; +} +else { + $h{150.146.64} = "ok"; +} print "$h{ok } $test\n"; ++$test; -$x = 77.78.79; +if (ord("\t") == 9) { # ASCII + $x = 77.78.79; +} +else { + $x = 212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -53,44 +79,103 @@ print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; print "ok $test\n"; ++$test; # test sprintf("%vd"...) etc -print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +} +else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; print "ok $test\n"; ++$test; -print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +} +else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; print "ok $test\n"; ++$test; -print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +} +else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%*vb", "##", v1.22.333.4444) eq '1##10110##101001101##1000101011100'; print "ok $test\n"; ++$test; +print "not " unless sprintf("%vd", join("", map { chr } + unpack "U*", v2001.2002.2003)) + eq '2001.2002.2003'; +print "ok $test\n"; ++$test; + { use bytes; - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + } + else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; print "ok $test\n"; ++$test; - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + } + else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; print "ok $test\n"; ++$test; - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + } + else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; + } print "ok $test\n"; ++$test; print "not " unless sprintf("%*vb", "##", v1.22.333.4444) eq '1##10110##11000101##10001101##11100001##10000101##10011100'; print "ok $test\n"; ++$test; } + +{ + # bug id 20000323.056 + + print "not " unless "\x{41}" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x41" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x{c8}" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\xc8" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\x{221b}" eq v8731; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t index 0a47b6d..4b6f37c 100755 --- a/contrib/perl5/t/op/wantarray.t +++ b/contrib/perl5/t/op/wantarray.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..7\n"; sub context { my ( $cona, $testnum ) = @_; my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; @@ -13,4 +13,8 @@ sub context { context('V',1); $a = context('S',2); @a = context('A',3); +scalar context('S',4); +$a = scalar context('S',5); +($a) = context('A',6); +($a) = scalar context('S',7); 1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 87d5042..5b01eb7 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -200,4 +200,21 @@ $this,$that write LEX; $that = 8; write LEX; + close LEX; } +# LEX_INTERPNORMAL test +my %e = ( a => 1 ); +format OUT4 = +@<<<<<< +"$e{a}" +. +open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; +write (OUT4); +close OUT4; +if (`$CAT Op_write.tmp` eq "1\n") { + print "ok 9\n"; + unlink "Op_write.tmp"; + } +else { + print "not ok 9\n"; + } diff --git a/contrib/perl5/t/pod/emptycmd.t b/contrib/perl5/t/pod/emptycmd.t index d348a9d..815eba2 100755 --- a/contrib/perl5/t/pod/emptycmd.t +++ b/contrib/perl5/t/pod/emptycmd.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/for.t b/contrib/perl5/t/pod/for.t index b8a6ec5..4af528a 100755 --- a/contrib/perl5/t/pod/for.t +++ b/contrib/perl5/t/pod/for.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/headings.t b/contrib/perl5/t/pod/headings.t index fc7b4b2..365aa7d 100755 --- a/contrib/perl5/t/pod/headings.t +++ b/contrib/perl5/t/pod/headings.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/include.t b/contrib/perl5/t/pod/include.t index 6d0b7e3..b6f1e31 100755 --- a/contrib/perl5/t/pod/include.t +++ b/contrib/perl5/t/pod/include.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/included.t b/contrib/perl5/t/pod/included.t index 0e31a09..a25b37b 100755 --- a/contrib/perl5/t/pod/included.t +++ b/contrib/perl5/t/pod/included.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/lref.t b/contrib/perl5/t/pod/lref.t index e367d6d..1dd8c68 100755 --- a/contrib/perl5/t/pod/lref.t +++ b/contrib/perl5/t/pod/lref.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/multiline_items.t b/contrib/perl5/t/pod/multiline_items.t index 37e8d53..334832d 100755 --- a/contrib/perl5/t/pod/multiline_items.t +++ b/contrib/perl5/t/pod/multiline_items.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/nested_items.t b/contrib/perl5/t/pod/nested_items.t index 9c09801..0b86702 100755 --- a/contrib/perl5/t/pod/nested_items.t +++ b/contrib/perl5/t/pod/nested_items.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/nested_seqs.t b/contrib/perl5/t/pod/nested_seqs.t index 6a5405b..9f30533 100755 --- a/contrib/perl5/t/pod/nested_seqs.t +++ b/contrib/perl5/t/pod/nested_seqs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/oneline_cmds.t b/contrib/perl5/t/pod/oneline_cmds.t index 3081ef4..bba0e4a 100755 --- a/contrib/perl5/t/pod/oneline_cmds.t +++ b/contrib/perl5/t/pod/oneline_cmds.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/pod2usage.t b/contrib/perl5/t/pod/pod2usage.t index bceeeef..70cbacd 100755 --- a/contrib/perl5/t/pod/pod2usage.t +++ b/contrib/perl5/t/pod/pod2usage.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/poderrs.t b/contrib/perl5/t/pod/poderrs.t index ec632c2..1b92ede 100755 --- a/contrib/perl5/t/pod/poderrs.t +++ b/contrib/perl5/t/pod/poderrs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testpchk.pl"; import TestPodChecker; } @@ -59,7 +59,7 @@ The above blank line contains tabs and spaces only =over 4 -=item oops +=item aaps =head2 end without begin @@ -75,6 +75,20 @@ The above blank line contains tabs and spaces only =end +second one results in end w/o begin + +=head2 begin w/o formatter + +=begin + +=end + +=head2 for w/o formatter + +=for + +something... + =head2 Nested sequences of the same type C<code I<italic C<code again!>>> @@ -84,6 +98,9 @@ C<code I<italic C<code again!>>> E<alea iacta est> E<C<auml>> E<abcI<bla>> +E<0x100> +E<07777> +E<300> =head2 Unresolved internal links @@ -96,12 +113,15 @@ L</OoPs> L<abc def> L<> +L< aha> +L<oho > L<"Warnings"> this one is ok +L</unescaped> ok too, this POD has an X of the same name =head2 Warnings L<passwd(5)> -L< some text|page/"section" > +L<some text with / in it|perlvar/$|> should give warnings as hell =over 4 @@ -109,17 +129,70 @@ L< some text|page/"section" > =back 200 +the 200 is evil + =begin html What? =end xml +X<unescaped>see these unescaped < and > in the text? + +=head2 Misc + +Z<ddd> should be empty + +X<> should not be empty + +=over four + +This paragrapgh is misplaced - it ought to be an item. + +=item four should be numeric! + +=item + +=item blah + +=item previous is all empty!!! + +=back + +All empty over/back: + +=over 4 + +=back + +item w/o name + +=cut + +=pod bla + +bla is evil + +=cut blub + +blub is evil + +=head2 reoccurence + =over 4 +=item Misc + +we already have a head Misc + =back -see these unescaped < and > in the text? +=head2 some heading + +=head2 another one + +previous section is empty! =cut + diff --git a/contrib/perl5/t/pod/poderrs.xr b/contrib/perl5/t/pod/poderrs.xr index b8e5e86..a21efdb 100644 --- a/contrib/perl5/t/pod/poderrs.xr +++ b/contrib/perl5/t/pod/poderrs.xr @@ -1,33 +1,46 @@ -*** ERROR: Unknown command 'unknown1' at line 25 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Q' at line 29 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'A' at line 30 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Y' at line 31 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence 'V' at line 31 in file pod/poderrs.t -*** ERROR: unterminated B<...> at line 35 in file pod/poderrs.t -*** ERROR: unterminated I<...> at line 34 in file pod/poderrs.t -*** ERROR: unterminated C<...> at line 37 in file pod/poderrs.t -*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file pod/poderrs.t -*** ERROR: =item without previous =over at line 52 in file pod/poderrs.t -*** ERROR: =back without previous =over at line 56 in file pod/poderrs.t -*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file pod/poderrs.t -*** ERROR: =end without =begin at line 66 in file pod/poderrs.t -*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file pod/poderrs.t -*** ERROR: =end without =begin at line 76 in file pod/poderrs.t -*** ERROR: nested commands C<...C<...>...> at line 80 in file pod/poderrs.t -*** ERROR: garbled entity E<alea iacta est> at line 84 in file pod/poderrs.t -*** ERROR: garbled entity E<C<auml>> at line 85 in file pod/poderrs.t -*** ERROR: garbled entity E<abcI<bla>> at line 86 in file pod/poderrs.t -*** WARNING: collapsing newlines to blanks at line 96 in file pod/poderrs.t -*** ERROR: malformed link L<> : empty link at line 98 in file pod/poderrs.t -*** WARNING: ignoring leading whitespace in link at line 104 in file pod/poderrs.t -*** WARNING: ignoring trailing whitespace in link at line 104 in file pod/poderrs.t -*** ERROR: Spurious character(s) after =back at line 110 in file pod/poderrs.t -*** WARNING: No items in =over (at line 118) / =back list at line 120 in file pod/poderrs.t -*** WARNING: 2 unescaped <> in paragraph at line 122 in file pod/poderrs.t -*** ERROR: unresolved internal link 'begin or begin' at line 90 in file pod/poderrs.t -*** ERROR: unresolved internal link 'end with begin' at line 91 in file pod/poderrs.t -*** ERROR: unresolved internal link 'OoPs' at line 92 in file pod/poderrs.t -*** ERROR: unresolved internal link 'abc def' at line 96 in file pod/poderrs.t -*** ERROR: unresolved internal link 'passwd(5)' at line 103 in file pod/poderrs.t -*** WARNING: multiple occurence of link target 'oops' at line - in file pod/poderrs.t -pod/poderrs.t has 25 pod syntax errors. +*** ERROR: Unknown command 'unknown1' at line 25 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Q' at line 29 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'A' at line 30 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Y' at line 31 in file t/pod/poderrs.t +*** ERROR: Unknown interior-sequence 'V' at line 31 in file t/pod/poderrs.t +*** ERROR: unterminated B<...> at line 35 in file t/pod/poderrs.t +*** ERROR: unterminated I<...> at line 34 in file t/pod/poderrs.t +*** ERROR: unterminated C<...> at line 37 in file t/pod/poderrs.t +*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file t/pod/poderrs.t +*** ERROR: =item without previous =over at line 52 in file t/pod/poderrs.t +*** ERROR: =back without previous =over at line 56 in file t/pod/poderrs.t +*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 66 in file t/pod/poderrs.t +*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file t/pod/poderrs.t +*** ERROR: =end without =begin at line 76 in file t/pod/poderrs.t +*** ERROR: No argument for =begin at line 82 in file t/pod/poderrs.t +*** ERROR: =for without formatter specification at line 88 in file t/pod/poderrs.t +*** ERROR: nested commands C<...C<...>...> at line 94 in file t/pod/poderrs.t +*** ERROR: garbled entity E<alea iacta est> at line 98 in file t/pod/poderrs.t +*** ERROR: garbled entity E<C<auml>> at line 99 in file t/pod/poderrs.t +*** ERROR: garbled entity E<abcI<bla>> at line 100 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<0x100> at line 101 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<07777> at line 102 in file t/pod/poderrs.t +*** ERROR: Entity number out of range E<300> at line 103 in file t/pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 115 in file t/pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 116 in file t/pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 117 in file t/pod/poderrs.t +*** WARNING: (section) in 'passwd(5)' deprecated at line 123 in file t/pod/poderrs.t +*** WARNING: node '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t +*** WARNING: alternative text '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t +*** ERROR: Spurious character(s) after =back at line 130 in file t/pod/poderrs.t +*** ERROR: Nonempty Z<> at line 144 in file t/pod/poderrs.t +*** ERROR: Empty X<> at line 146 in file t/pod/poderrs.t +*** WARNING: preceding non-item paragraph(s) at line 152 in file t/pod/poderrs.t +*** WARNING: No argument for =item at line 154 in file t/pod/poderrs.t +*** WARNING: previous =item has no contents at line 156 in file t/pod/poderrs.t +*** WARNING: No items in =over (at line 164) / =back list at line 166 in file t/pod/poderrs.t +*** ERROR: Spurious text after =pod at line 172 in file t/pod/poderrs.t +*** ERROR: Spurious text after =cut at line 176 in file t/pod/poderrs.t +*** WARNING: empty section in previous paragraph at line 192 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'begin or begin' at line 107 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'end with begin' at line 108 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'OoPs' at line 109 in file t/pod/poderrs.t +*** ERROR: unresolved internal link 'abc def' at line 113 in file t/pod/poderrs.t +*** WARNING: multiple occurence of link target 'Misc' at line - in file t/pod/poderrs.t +t/pod/poderrs.t has 33 pod syntax errors. diff --git a/contrib/perl5/t/pod/podselect.t b/contrib/perl5/t/pod/podselect.t index 30eb30c..5d45cdb 100755 --- a/contrib/perl5/t/pod/podselect.t +++ b/contrib/perl5/t/pod/podselect.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } diff --git a/contrib/perl5/t/pod/special_seqs.t b/contrib/perl5/t/pod/special_seqs.t index b8af57e..c6b2ce1 100755 --- a/contrib/perl5/t/pod/special_seqs.t +++ b/contrib/perl5/t/pod/special_seqs.t @@ -1,7 +1,7 @@ -#!./perl BEGIN { chdir 't' if -d 't'; - unshift @INC, './pod', '../lib'; + unshift @INC, '../lib'; + unshift @INC, './pod'; require "testp2pt.pl"; import TestPodIncPlainText; } @@ -40,4 +40,7 @@ So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end up doing what you might expect since the first > will still terminate the first < seen. +Lets make sure these work for empty ones too, like C<< >> and C<< >> >> +(just to be obnoxious) + =cut diff --git a/contrib/perl5/t/pod/special_seqs.xr b/contrib/perl5/t/pod/special_seqs.xr index a07f4cf..a8c715a 100644 --- a/contrib/perl5/t/pod/special_seqs.xr +++ b/contrib/perl5/t/pod/special_seqs.xr @@ -20,3 +20,6 @@ up doing what you might expect since the first > will still terminate the first < seen. + Lets make sure these work for empty ones too, like and `>>' (just to be + obnoxious) + diff --git a/contrib/perl5/t/pod/testp2pt.pl b/contrib/perl5/t/pod/testp2pt.pl index 2ff8aa4..8cfdbb9 100644 --- a/contrib/perl5/t/pod/testp2pt.pl +++ b/contrib/perl5/t/pod/testp2pt.pl @@ -42,8 +42,11 @@ BEGIN { sub catfile(@) { File::Spec->catfile(@_); } my $INSTDIR = abs_path(dirname $0); -$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; -$INSTDIR =~ s#/$## if $^O eq 'VMS'; +if ($^O eq 'VMS') { # clean up directory spec + $INSTDIR = VMS::Filespec::unixpath($INSTDIR); + $INSTDIR =~ s#/$##; + $INSTDIR =~ s#/000000/#/#; +} $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), @@ -51,6 +54,7 @@ my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), catfile($INSTDIR, 'pod'), catfile($INSTDIR, 't', 'pod') ); +print "PODINCDIRS = ",join(', ',@PODINCDIRS),"\n"; ## Find the path to the file to =include sub findinclude { @@ -106,7 +110,7 @@ sub begin_input { sub podinc2plaintext( $ $ ) { my ($infile, $outfile) = @_; local $_; - my $text_parser = $MYPKG->new; + my $text_parser = $MYPKG->new(quotes => "`'"); $text_parser->parse_from_file($infile, $outfile); } diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 6438332..6e6617b 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use warnings; diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t index 15cd6b5..14014f6 100755 --- a/contrib/perl5/t/pragma/diagnostics.t +++ b/contrib/perl5/t/pragma/diagnostics.t @@ -1,8 +1,8 @@ #!./perl BEGIN { - chdir '..' if -d '../pod'; - unshift @INC, './lib' if -d './lib'; + chdir '..' if -d '../pod' && -d '../t'; + @INC = 'lib'; } diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 414ceff..068fede 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; unshift @INC, '.'; require Config; import Config; if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { @@ -15,8 +15,18 @@ use strict; my $debug = 1; +use Dumpvalue; + +my $dumper = Dumpvalue->new( + tick => qq{"}, + quoteHighBit => 0, + unctrl => "quote" + ); sub debug { - print @_ if $debug; + return unless $debug; + my($mess) = join "", @_; + chop $mess; + print $dumper->stringify($mess,1), "\n"; } sub debugf { @@ -34,7 +44,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -print "1..", ($have_setlocale ? 116 : 98), "\n"; +my $last = $have_setlocale ? 116 : 98; + +print "1..$last\n"; use vars qw(&LC_ALL); @@ -242,13 +254,13 @@ Afrikaans:af:za:1 15 Arabic:ar:dz eg sa:6 arabic8 Brezhoneg Breton:br:fr:1 15 Bulgarski Bulgarian:bg:bg:5 -Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC +Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC Hrvatski Croatian:hr:hr:2 Cymraeg Welsh:cy:cy:1 14 15 Czech:cs:cz:2 Dansk Danish:dk:da:1 15 Nederlands Dutch:nl:be nl:1 15 -English American British:en:au ca gb ie nz us uk:1 15 cp850 +English American British:en:au ca gb ie nz us uk zw:1 15 cp850 Esperanto:eo:eo:3 Eesti Estonian:et:ee:4 6 13 Suomi Finnish:fi:fi:1 15 @@ -271,11 +283,12 @@ Latvian:lv:lv:4 6 13 Lithuanian:lt:lt:4 6 13 Macedonian:mk:mk:1 15 Maltese:mt:mt:3 -Norsk Norwegian:no:no:1 15 +Moldovan:mo:mo:2 +Norsk Norwegian:no no\@nynorsk:no:1 15 Occitan:oc:es:1 15 Polski Polish:pl:pl:2 Rumanian:ro:ro:2 -Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251 +Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 Serbski Serbian:sr:yu:5 Slovak:sk:sk:2 Slovene Slovenian:sl:si:2 @@ -283,10 +296,11 @@ Sqhip Albanian:sq:sq:1 15 Svenska Swedish:sv:fi se:1 15 Thai:th:th:11 tis620 Turkish:tr:tr:9 turkish8 -Yiddish:::1 15 +Yiddish:yi::1 15 EOF if ($^O eq 'os390') { + # These cause heartburn. Broken locales? $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; $locales =~ s/Thai:th:th:11 tis620\n//; } @@ -326,6 +340,7 @@ sub decode_encodings { } } else { push @enc, $_; + push @enc, "$_.UTF-8"; } } if ($^O eq 'os390') { @@ -347,32 +362,61 @@ foreach (0..15) { trylocale("iso_latin_$_"); } -foreach my $locale (split(/\n/, $locales)) { - my ($locale_name, $language_codes, $country_codes, $encodings) = - split(/:/, $locale); - my @enc = decode_encodings($encodings); - foreach my $loc (split(/ /, $locale_name)) { - trylocale($loc); - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } - $loc = lc $loc; - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } +# Sanitize the environment so that we can run the external 'locale' +# program without the taint mode getting grumpy. + +# $ENV{PATH} is special in VMS. +delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; + +# Other subversive stuff. +delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; + +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { + while (<LOCALES>) { + chomp; + trylocale($_); } - foreach my $lang (split(/ /, $language_codes)) { - trylocale($lang); - foreach my $country (split(/ /, $country_codes)) { - my $lc = "${lang}_${country}"; - trylocale($lc); + close(LOCALES); +} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { +# The SYS$I18N_LOCALE logical name search list was not present on +# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. + opendir(LOCALES, "SYS\$I18N_LOCALE:"); + while ($_ = readdir(LOCALES)) { + chomp; + trylocale($_); + } + close(LOCALES); +} else { + + # This is going to be slow. + + foreach my $locale (split(/\n/, $locales)) { + my ($locale_name, $language_codes, $country_codes, $encodings) = + split(/:/, $locale); + my @enc = decode_encodings($encodings); + foreach my $loc (split(/ /, $locale_name)) { + trylocale($loc); foreach my $enc (@enc) { - trylocale("$lc.$enc"); + trylocale("$loc.$enc"); } - my $lC = "${lang}_\U${country}"; - trylocale($lC); + $loc = lc $loc; foreach my $enc (@enc) { - trylocale("$lC.$enc"); + trylocale("$loc.$enc"); + } + } + foreach my $lang (split(/ /, $language_codes)) { + trylocale($lang); + foreach my $country (split(/ /, $country_codes)) { + my $lc = "${lang}_${country}"; + trylocale($lc); + foreach my $enc (@enc) { + trylocale("$lc.$enc"); + } + my $lC = "${lang}_\U${country}"; + trylocale($lC); + foreach my $enc (@enc) { + trylocale("$lC.$enc"); + } } } } @@ -380,6 +424,8 @@ foreach my $locale (split(/\n/, $locales)) { setlocale(LC_ALL, "C"); +sub utf8locale { $_[0] =~ /utf-?8/i } + @Locale = sort @Locale; debug "# Locales = @Locale\n"; @@ -392,8 +438,6 @@ my %Neoalpha; sub tryneoalpha { my ($Locale, $i, $test) = @_; - debug "# testing $i with locale '$Locale'\n" - unless $Testing{$i}{$Locale}++; unless ($test) { $Problem{$i}{$Locale} = 1; debug "# failed $i with locale '$Locale'\n"; @@ -405,7 +449,7 @@ sub tryneoalpha { foreach $Locale (@Locale) { debug "# Locale = $Locale\n"; @Alnum_ = getalnum_(); - debug "# \\w = @Alnum_\n"; + debug "# w = ", join("",@Alnum_), "\n"; unless (setlocale(LC_ALL, $Locale)) { foreach (99..103) { @@ -440,9 +484,9 @@ foreach $Locale (@Locale) { delete $lower{$_}; } - debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; - debug "# lower = ", join(" ", sort keys %lower ), "\n"; - debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; + debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; + debug "# lower = ", join("", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; # Find the alphabets that are not alphabets in the default locale. @@ -458,7 +502,7 @@ foreach $Locale (@Locale) { @Neoalpha = sort @Neoalpha; - debug "# Neoalpha = @Neoalpha\n"; + debug "# Neoalpha = ", join("",@Neoalpha), "\n"; if (@Neoalpha == 0) { # If we have no Neoalphas the remaining tests are no-ops. @@ -470,7 +514,10 @@ foreach $Locale (@Locale) { # Test \w. - { + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { my $word = join('', @Neoalpha); $word =~ /^(\w+)$/; @@ -622,7 +669,9 @@ foreach $Locale (@Locale) { tryneoalpha($Locale, 114, $f == $c); } - debug "# testing 115 with locale '$Locale'\n"; + # Does taking lc separately differ from taking + # the lc "in-line"? (This was the bug 19990704.002, change #3568.) + # The bug was in the caching of the 'o'-magic. { use locale; @@ -645,8 +694,13 @@ foreach $Locale (@Locale) { lcA($x, $z) == 0 && lcB($x, $z) == 0); } - debug "# testing 116 with locale '$Locale'\n"; - { + # Does lc of an UPPER (if different from the UPPER) match + # case-insensitively the UPPER, and does the UPPER match + # case-insensitively the lc of the UPPER. And vice versa. + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { use locale; my @f = (); @@ -661,14 +715,16 @@ foreach $Locale (@Locale) { push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } tryneoalpha($Locale, 116, @f == 0); - print "# testing 116 failed for locale '$Locale' for characters @f\n" - if @f; + if (@f) { + print "# failed 116 locale '$Locale' characters @f\n" + } } + } # Recount the errors. -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { if ($_ == 102) { print "# The failure of test 102 is not necessarily fatal.\n"; @@ -684,7 +740,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -709,26 +765,43 @@ EOW } } -# Tell which locales ere okay. +# Tell which locales were okay and which were not. if ($didwarn) { - my @s; + my (@s, @F); foreach my $l (@Locale) { my $p = 0; - foreach my $t (102..102) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } - my $s = join(" ", @s); - $s =~ s/(.{50,60}) /$1\n#\t/g; + if (@s) { + my $s = join(" ", @s); + $s =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $s, "\n#\n", + "# tested okay.\n#\n", + } else { + warn "# None of your locales were fully okay.\n"; + } - warn - "# The following locales\n#\n", - "#\t", $s, "\n#\n", - "# tested okay.\n#\n", + if (@F) { + my $F = join(" ", @F); + $F =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $F, "\n#\n", + "# had problems.\n#\n", + } else { + warn "# None of your locales were broken.\n"; + } } # eof diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index f9a9c59..a3007ef 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } package Oscalar; @@ -919,14 +919,69 @@ test $bar->[3], 13; # 206 my $aaa; { my $bbbb = 0; $aaa = bless \$bbbb, B } -test !$aaa, 1; +test !$aaa, 1; # 207 unless ($aaa) { - test 'ok', 'ok'; + test 'ok', 'ok'; # 208 } else { - test 'is not', 'ok'; + test 'is not', 'ok'; # 208 } +# check that overload isn't done twice by join +{ my $c = 0; + package Join; + use overload '""' => sub { $c++ }; + my $x = join '', bless([]), 'pq', bless([]); + main::test $x, '0pq1'; # 209 +}; + +# Test module-specific warning +{ + # check the Odd number of arguments for overload::constant warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "integer" ; ' ; + test($a eq "") ; # 210 + use warnings 'overload' ; + $x = eval ' overload::constant "integer" ; ' ; + test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 +} + +{ + # check the `$_[0]' is not an overloadable type warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "fred" => sub {} ; ' ; + test($a eq "") ; # 212 + use warnings 'overload' ; + $x = eval ' overload::constant "fred" => sub {} ; ' ; + test($a =~ /^`fred' is not an overloadable type at/); # 213 +} + +{ + # check the `$_[1]' is not a code reference warning + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' overload::constant "integer" => 1; ' ; + test($a eq "") ; # 214 + use warnings 'overload' ; + $x = eval ' overload::constant "integer" => 1; ' ; + test($a =~ /^`1' is not a code reference at/); # 215 +} + +# make sure that we don't inifinitely recurse +{ + my $c = 0; + package Recurse; + use overload '""' => sub { shift }, + '0+' => sub { shift }, + 'bool' => sub { shift }, + fallback => 1; + my $x = bless([]); + main::test("$x" =~ /Recurse=ARRAY/); # 216 + main::test($x); # 217 + main::test($x+0 =~ /Recurse=ARRAY/); # 218 +}; # Last test is: -sub last {208} +sub last {218} diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars index ae09742..40b5557 100644 --- a/contrib/perl5/t/pragma/strict-vars +++ b/contrib/perl5/t/pragma/strict-vars @@ -55,7 +55,7 @@ Execution of - aborted due to compilation errors. # strict vars - error use strict 'vars' ; -$fred ; +<$fred> ; EXPECT Global symbol "$fred" requires explicit package name at - line 4. Execution of - aborted due to compilation errors. @@ -151,8 +151,6 @@ $d = 1;$i = 1;$n = 1; $e = 1;$j = 1;$o = 1; $p = 0b12; --FILE-- -# known scalar leak -BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } use abc; EXPECT Global symbol "$f" requires explicit package name at abc.pm line 3. @@ -171,8 +169,8 @@ Global symbol "$o" requires explicit package name at abc.pm line 7. Global symbol "$p" requires explicit package name at abc.pm line 8. Illegal binary digit '2' at abc.pm line 8, at end of line abc.pm has too many errors. -Compilation failed in require at - line 3. -BEGIN failed--compilation aborted at - line 3. +Compilation failed in require at - line 1. +BEGIN failed--compilation aborted at - line 1. ######## # Check scope of pragma with eval @@ -387,6 +385,8 @@ EXPECT # multiple our declarations in same scope, same package, warning use strict 'vars'; use warnings; +{ our $x = 1 } +{ our $x = 0 } our $foo; { our $foo; @@ -394,6 +394,17 @@ our $foo; our $foo; } EXPECT -"our" variable $foo redeclared at - line 7. +"our" variable $foo redeclared at - line 9. (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 9. +Name "Foo::foo" used only once: possible typo at - line 11. +######## + +# Make sure the strict vars failure still occurs +# now that the `@i should be written as \@i' failure does not occur +# 20000522 mjd@plover.com (MJD) +use strict 'vars'; +no warnings; +"@i_like_crackers"; +EXPECT +Global symbol "@i_like_crackers" requires explicit package name at - line 7. +Execution of - aborted due to compilation errors. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t index c4d6416..5b245d0 100755 --- a/contrib/perl5/t/pragma/strict.t +++ b/contrib/perl5/t/pragma/strict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -19,7 +19,7 @@ my @prgs = () ; foreach (sort glob("pragma/strict-*")) { - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t index e96c329..f19268b 100755 --- a/contrib/perl5/t/pragma/sub_lval.t +++ b/contrib/perl5/t/pragma/sub_lval.t @@ -1,12 +1,12 @@ -print "1..46\n"; +print "1..64\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -sub a : lvalue { my $a = 34; bless \$a } # Return a temporary -sub b : lvalue { shift } +sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary +sub b : lvalue { ${\shift} } my $out = a(b()); # Check that temporaries are allowed. print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. @@ -34,9 +34,9 @@ print "ok 3\n"; sub get_lex : lvalue { $in } sub get_st : lvalue { $blah } -sub id : lvalue { shift } +sub id : lvalue { ${\shift} } sub id1 : lvalue { $_[0] } -sub inc : lvalue { ++$_[0] } +sub inc : lvalue { ${\++$_[0]} } $in = 5; $blah = 3; @@ -288,40 +288,41 @@ print "# '$_'.\nnot " print "ok 34\n"; $x = '1234567'; -sub lv1t : lvalue { index $x, 2 } $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1t : lvalue { index $x, 2 } lv1t = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify index in lvalue subroutine return/; print "ok 35\n"; $_ = undef; eval <<'EOE' or $_ = $@; - (lv1t) = (2,3); + sub lv2t : lvalue { shift } + (lv2t) = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify shift in lvalue subroutine return/; print "ok 36\n"; $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue -sub lv1tmp : lvalue { xxx } # is it a TEMP? $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmp : lvalue { xxx } # is it a TEMP? lv1tmp = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a temporary from lvalue subroutine/; + unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; print "ok 37\n"; $_ = undef; @@ -334,17 +335,17 @@ print "# '$_'.\nnot " unless /Can\'t return a temporary from lvalue subroutine/; print "ok 38\n"; -sub xxx () { 'xxx' } # Not lvalue -sub lv1tmpr : lvalue { xxx } # is it a TEMP? +sub yyy () { 'yyy' } # Const, not lvalue $_ = undef; eval <<'EOE' or $_ = $@; + sub lv1tmpr : lvalue { yyy } # is it read-only? lv1tmpr = (2,3); 1; EOE print "# '$_'.\nnot " - unless /Can\'t return a readonly value from lvalue subroutine/; + unless /Can\'t modify constant item in lvalue subroutine return/; print "ok 39\n"; $_ = undef; @@ -357,8 +358,6 @@ print "# '$_'.\nnot " unless /Can\'t return a readonly value from lvalue subroutine/; print "ok 40\n"; -=for disabled constructs - sub lva : lvalue {@a} $_ = undef; @@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -print "# '$_'.\nnot " - unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 41\n"; $_ = undef; @@ -397,10 +395,6 @@ EOE print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; print "ok 43\n"; -=cut - -print "ok $_\n" for 41..43; - sub lv1n : lvalue { $newvar } $_ = undef; @@ -427,3 +421,122 @@ $a = \&lv1nn; $a->() = 8; print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; print "ok 46\n"; + +# This must happen at run time +eval { + sub AUTOLOAD : lvalue { $newvar }; +}; +foobar() = 12; +print "# '$newvar'.\nnot " unless $newvar eq "12"; +print "ok 47\n"; + +# Testing DWIM of foo = bar; +sub foo : lvalue { + $a; +} +$a = "not ok 48\n"; +foo = "ok 48\n"; +print $a; + +open bar, ">nothing" or die $!; +bar = *STDOUT; +print bar "ok 49\n"; +unlink "nothing"; + +{ +my %hash; my @array; +sub alv : lvalue { $array[1] } +sub alv2 : lvalue { $array[$_[0]] } +sub hlv : lvalue { $hash{"foo"} } +sub hlv2 : lvalue { $hash{$_[0]} } +$array[1] = "not ok 51\n"; +alv() = "ok 50\n"; +print alv(); + +alv2(20) = "ok 51\n"; +print $array[20]; + +$hash{"foo"} = "not ok 52\n"; +hlv() = "ok 52\n"; +print $hash{foo}; + +$hash{bar} = "not ok 53\n"; +hlv("bar") = "ok 53\n"; +print hlv("bar"); + +sub array : lvalue { @array } +sub array2 : lvalue { @array2 } # This is a global. +sub hash : lvalue { %hash } +sub hash2 : lvalue { %hash2 } # So's this. +@array2 = qw(foo bar); +%hash2 = qw(foo bar); + +(array()) = qw(ok 54); +print "not " unless "@array" eq "ok 54"; +print "ok 54\n"; + +(array2()) = qw(ok 55); +print "not " unless "@array2" eq "ok 55"; +print "ok 55\n"; + +(hash()) = qw(ok 56); +print "not " unless $hash{ok} == 56; +print "ok 56\n"; + +(hash2()) = qw(ok 57); +print "not " unless $hash2{ok} == 57; +print "ok 57\n"; + +@array = qw(a b c d); +sub aslice1 : lvalue { @array[0,2] }; +(aslice1()) = ("ok", "already"); +print "# @array\nnot " unless "@array" eq "ok b already d"; +print "ok 58\n"; + +@array2 = qw(a B c d); +sub aslice2 : lvalue { @array2[0,2] }; +(aslice2()) = ("ok", "already"); +print "not " unless "@array2" eq "ok B already d"; +print "ok 59\n"; + +%hash = qw(a Alpha b Beta c Gamma); +sub hslice : lvalue { @hash{"c", "b"} } +(hslice()) = ("CISC", "BogoMIPS"); +print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; +print "ok 60\n"; +} + +$str = "Hello, world!"; +sub sstr : lvalue { substr($str, 1, 4) } +sstr() = "i"; +print "not " unless $str eq "Hi, world!"; +print "ok 61\n"; + +$str = "Made w/ JavaScript"; +sub veclv : lvalue { vec($str, 2, 32) } +if (ord('A') != 193) { + veclv() = 0x5065726C; +} +else { # EBCDIC? + veclv() = 0xD7859993; +} +print "# $str\nnot " unless $str eq "Made w/ PerlScript"; +print "ok 62\n"; + +sub position : lvalue { pos } +@p = (); +$_ = "fee fi fo fum"; +while (/f/g) { + push @p, position; + position() += 6; +} +print "# @p\nnot " unless "@p" eq "1 8"; +print "ok 63\n"; + +# Bug 20001223.002: split thought that the list had only one element +@ary = qw(4 5 6); +sub lval1 : lvalue { $ary[0]; } +sub lval2 : lvalue { $ary[1]; } +(lval1(), lval2()) = split ' ', "1 2 3 4"; +print "not " unless join(':', @ary) eq "1:2:6"; +print "ok 64\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index fe84f5e..7e48e20 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -114,6 +114,30 @@ EXPECT 3 ######## +# override a built-in function, call after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open 1,2 ; +EXPECT +3 +######## + +# override a built-in function, call with () +use subs qw( open ) ; +open (1,2) ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function, call with () after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open (1,2) ; +EXPECT +3 +######## + --FILE-- abc Fred 1,2 ; 1; diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t index 0e55a67..e0a321a 100755 --- a/contrib/perl5/t/pragma/utf8.t +++ b/contrib/perl5/t/pragma/utf8.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; if ( ord("\t") != 9 ) { # skip on ebcdic platforms print "1..0 # Skip utf8 tests on ebcdic platform.\n"; @@ -10,7 +10,7 @@ BEGIN { } } -print "1..60\n"; +print "1..90\n"; my $test = 1; @@ -20,234 +20,443 @@ sub ok { print "ok $test\n"; } +sub nok { + my ($got,$expect) = @_; + print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; + print "ok $test\n"; +} + +sub ok_bytes { + use bytes; + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +sub nok_bytes { + use bytes; + my ($got,$expect) = @_; + print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; + print "ok $test\n"; +} + { use utf8; $_ = ">\x{263A}<"; s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 1 $_ = ">\x{263A}<"; my $rx = "\x{80}-\x{10ffff}"; s/([$rx])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 2 $_ = ">\x{263A}<"; my $rx = "\\x{80}-\\x{10ffff}"; s/([$rx])/"&#".ord($1).";"/eg; ok $_, '>☺<'; - $test++; + $test++; # 3 $_ = "alpha,numeric"; m/([[:alpha:]]+)/; ok $1, 'alpha'; - $test++; + $test++; # 4 $_ = "alphaNUMERICstring"; m/([[:^lower:]]+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 5 $_ = "alphaNUMERICstring"; m/(\p{Ll}+)/; ok $1, 'alpha'; - $test++; + $test++; # 6 $_ = "alphaNUMERICstring"; m/(\p{Lu}+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 7 $_ = "alpha,numeric"; m/([\p{IsAlpha}]+)/; ok $1, 'alpha'; - $test++; + $test++; # 8 $_ = "alphaNUMERICstring"; m/([^\p{IsLower}]+)/; ok $1, 'NUMERIC'; - $test++; + $test++; # 9 $_ = "alpha123numeric456"; m/([\p{IsDigit}]+)/; ok $1, '123'; - $test++; + $test++; # 10 $_ = "alpha123numeric456"; m/([^\p{IsDigit}]+)/; ok $1, 'alpha'; - $test++; + $test++; # 11 $_ = ",123alpha,456numeric"; m/([\p{IsAlnum}]+)/; ok $1, '123alpha'; - $test++; + $test++; # 12 } + { use utf8; $_ = "\x{263A}>\x{263A}\x{263A}"; ok length, 4; - $test++; + $test++; # 13 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 14 ok length($&), 2; - $test++; + $test++; # 15 ok length($'), 1; - $test++; + $test++; # 16 ok length($`), 1; - $test++; + $test++; # 17 ok length($1), 1; - $test++; + $test++; # 18 ok length($tmp=$&), 2; - $test++; + $test++; # 19 ok length($tmp=$'), 1; - $test++; + $test++; # 20 ok length($tmp=$`), 1; - $test++; + $test++; # 21 ok length($tmp=$1), 1; - $test++; + $test++; # 22 - ok $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; + { + use bytes; - ok $', pack("C*", 0342, 0230, 0272); - $test++; + my $tmp = $&; + ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 23 - ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $'; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 24 - ok $1, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $`; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 25 + + $tmp = $1; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 26 + } + + ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 27 + + ok_bytes $', pack("C*", 0342, 0230, 0272); + $test++; # 28 + + ok_bytes $`, pack("C*", 0342, 0230, 0272); + $test++; # 29 + + ok_bytes $1, pack("C*", 0342, 0230, 0272); + $test++; # 30 { use bytes; no utf8; ok length, 10; - $test++; + $test++; # 31 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 32 ok length($&), 2; - $test++; + $test++; # 33 ok length($'), 5; - $test++; + $test++; # 34 ok length($`), 3; - $test++; + $test++; # 35 ok length($1), 1; - $test++; + $test++; # 36 ok $&, pack("C*", ord(">"), 0342); - $test++; + $test++; # 37 ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; + $test++; # 38 ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $test++; # 39 ok $1, pack("C*", 0342); - $test++; - + $test++; # 40 } - { no utf8; $_="\342\230\272>\342\230\272\342\230\272"; } ok length, 10; - $test++; + $test++; # 41 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 42 ok length($&), 2; - $test++; + $test++; # 43 ok length($'), 1; - $test++; + $test++; # 44 ok length($`), 1; - $test++; + $test++; # 45 ok length($1), 1; - $test++; + $test++; # 46 ok length($tmp=$&), 2; - $test++; + $test++; # 47 ok length($tmp=$'), 1; - $test++; + $test++; # 48 ok length($tmp=$`), 1; - $test++; + $test++; # 49 ok length($tmp=$1), 1; - $test++; + $test++; # 50 - ok $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; + { + use bytes; - ok $', pack("C*", 0342, 0230, 0272); - $test++; + my $tmp = $&; + ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; # 51 - ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $'; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 52 - ok $1, pack("C*", 0342, 0230, 0272); - $test++; + $tmp = $`; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 53 + + $tmp = $1; + ok $tmp, pack("C*", 0342, 0230, 0272); + $test++; # 54 + } { use bytes; no utf8; ok length, 10; - $test++; + $test++; # 55 ok length((m/>(.)/)[0]), 1; - $test++; + $test++; # 56 ok length($&), 2; - $test++; + $test++; # 57 ok length($'), 5; - $test++; + $test++; # 58 ok length($`), 3; - $test++; + $test++; # 59 ok length($1), 1; - $test++; + $test++; # 60 ok $&, pack("C*", ord(">"), 0342); - $test++; + $test++; # 61 ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; + $test++; # 62 ok $`, pack("C*", 0342, 0230, 0272); - $test++; + $test++; # 63 ok $1, pack("C*", 0342); + $test++; # 64 + } + + ok "\x{ab}" =~ /^\x{ab}$/, 1; + $test++; # 65 +} + +{ + use utf8; + ok join(" ",unpack("C*",chr(128).chr(255))), "128 255"; + $test++; +} + +{ + use utf8; + my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); + ok "@a", "1234 123 2345"; + $test++; # 67 +} + +{ + use utf8; + my $x = chr(123); + my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); + ok "@a", "1234 2345"; + $test++; # 68 +} + +{ + # bug id 20001009.001 + + my ($a, $b); + + { use bytes; $a = "\xc3\xa4" } + { use utf8; $b = "\xe4" } # \xXX must not produce UTF-8 + + print "not " if $a eq $b; + print "ok $test\n"; $test++; + + { use utf8; print "not " if $a eq $b; } + print "ok $test\n"; $test++; +} + +{ + # bug id 20001008.001 + + my @x = ("stra\337e 138","stra\337e 138"); + for (@x) { + s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; + my($latin) = /^(.+)(?:\s+\d)/; + print $latin eq "stra\337e" ? "ok $test\n" : + "#latin[$latin]\nnot ok $test\n"; + $test++; + $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a + use utf8; + $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a + } +} + +{ + # bug id 20000427.003 + + use utf8; + use warnings; + use strict; + + my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; + + my @charlist = split //, $sushi; + my $r = ''; + foreach my $ch (@charlist) { + $r = $r . " " . sprintf "U+%04X", ord($ch); + } + + print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; + print "ok $test\n"; + $test++; +} + +{ + # bug id 20000426.003 + + use utf8; + + my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; + + my ($a, $b, $c) = split(/\x40/, $s); + print "not " + unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x{100}/, $s); + print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); + print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b) = split(/\x40\x{80}/, $s); + print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"; + print "ok $test\n"; + $test++; + + my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); + print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"; + print "ok $test\n"; + $test++; +} + +{ + # bug id 20000730.004 + + use utf8; + + my $smiley = "\x{263a}"; + + for my $s ("\x{263a}", # 1 + $smiley, # 2 + + "" . $smiley, # 3 + "" . "\x{263a}", # 4 + + $smiley . "", # 5 + "\x{263a}" . "", # 6 + ) { + my $length_chars = length($s); + my $length_bytes; + { use bytes; $length_bytes = length($s) } + my @regex_chars = $s =~ m/(.)/g; + my $regex_chars = @regex_chars; + my @split_chars = split //, $s; + my $split_chars = @split_chars; + print "not " + unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq + "1/1/1/3"; + print "ok $test\n"; $test++; + } + for my $s ("\x{263a}" . "\x{263a}", # 7 + $smiley . $smiley, # 8 + + "\x{263a}\x{263a}", # 9 + "$smiley$smiley", # 10 + + "\x{263a}" x 2, # 11 + $smiley x 2, # 12 + ) { + my $length_chars = length($s); + my $length_bytes; + { use bytes; $length_bytes = length($s) } + my @regex_chars = $s =~ m/(.)/g; + my $regex_chars = @regex_chars; + my @split_chars = split //, $s; + my $split_chars = @split_chars; + print "not " + unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq + "2/2/2/6"; + print "ok $test\n"; + $test++; } } diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use index 60a60c3..b489d62 100644 --- a/contrib/perl5/t/pragma/warn/2use +++ b/contrib/perl5/t/pragma/warn/2use @@ -120,175 +120,223 @@ Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval -no warnings ; -eval { +use warnings; +{ + no warnings ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval { - use warnings 'uninitialized' ; +use warnings; +{ + no warnings ; + eval { + use warnings 'uninitialized' ; + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 6. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval { +no warnings; +{ + use warnings 'uninitialized' ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 5. Use of uninitialized value in scalar chop at - line 7. +Use of uninitialized value in scalar chop at - line 9. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval { - no warnings ; +no warnings; +{ + use warnings 'uninitialized' ; + eval { + no warnings ; + my $b ; chop $b ; + }; print STDERR $@ ; my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval { +use warnings; +{ + no warnings ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval { - use warnings 'deprecated' ; +use warnings; +{ + no warnings ; + eval { + use warnings 'deprecated' ; + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 6. +Use of EQ is deprecated at - line 8. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval { +no warnings; +{ + use warnings 'deprecated' ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 5. Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at - line 9. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval { - no warnings ; +no warnings; +{ + use warnings 'deprecated' ; + eval { + no warnings ; + 1 if $a EQ $b ; + }; print STDERR $@ ; 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval ' +use warnings; +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval q[ - use warnings 'uninitialized' ; +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; my $b ; chop $b ; -]; print STDERR $@; -my $b ; chop $b ; +} EXPECT Use of uninitialized value in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval ' +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 7. +Use of uninitialized value in scalar chop at - line 9. ######## # Check scope of pragma with eval -use warnings 'uninitialized' ; -eval ' - no warnings ; +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; +} EXPECT -Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 10. ######## # Check scope of pragma with eval -no warnings ; -eval ' +use warnings; +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; 1 if $a EQ $b ; -'; print STDERR $@ ; -1 if $a EQ $b ; +} EXPECT ######## # Check scope of pragma with eval -no warnings ; -eval q[ - use warnings 'deprecated' ; +use warnings; +{ + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; 1 if $a EQ $b ; -]; print STDERR $@; -1 if $a EQ $b ; +} EXPECT Use of EQ is deprecated at (eval 1) line 3. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval ' +no warnings; +{ + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; 1 if $a EQ $b ; -'; print STDERR $@; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at - line 9. Use of EQ is deprecated at (eval 1) line 2. ######## # Check scope of pragma with eval -use warnings 'deprecated' ; -eval ' - no warnings ; +no warnings; +{ + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; 1 if $a EQ $b ; -'; print STDERR $@; -1 if $a EQ $b ; +} EXPECT -Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 10. ######## # Check the additive nature of the pragma diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both index 132b99b..335e1b2 100644 --- a/contrib/perl5/t/pragma/warn/3both +++ b/contrib/perl5/t/pragma/warn/3both @@ -195,3 +195,72 @@ my $b ; chop $b ; EXPECT Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 0 } +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 9. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 0 } +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at - line 10. +######## + +# Check scope of pragma with eval +BEGIN { $^W = 1 } +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint index db54f31..b2fa75f 100644 --- a/contrib/perl5/t/pragma/warn/4lint +++ b/contrib/perl5/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 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 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 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 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 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 STDIN at - line 5. ######## -W --FILE-- abc.pm @@ -110,3 +110,107 @@ my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. Use of uninitialized value in scalar chop at - line 3. +######## +-W +# Check scope of pragma with eval +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 8. +######## +-W +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +Use of uninitialized value in scalar chop at - line 10. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 9. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +Use of uninitialized value in scalar chop at - line 10. +######## +-W +# Check scope of pragma with eval +use warnings; +{ + my $a = "1"; my $b = "2"; + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 11. +Use of EQ is deprecated at (eval 1) line 3. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + my $a = "1"; my $b = "2"; + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 10. +Use of EQ is deprecated at (eval 1) line 2. +######## +-W +# Check scope of pragma with eval +no warnings; +{ + my $a = "1"; my $b = "2"; + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT +Use of EQ is deprecated at - line 11. +Use of EQ is deprecated at (eval 1) line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint index 994190a..2459968 100644 --- a/contrib/perl5/t/pragma/warn/5nolint +++ b/contrib/perl5/t/pragma/warn/5nolint @@ -94,3 +94,111 @@ $^W = 1 ; require "./abc"; my $a ; chop $a ; EXPECT +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'uninitialized' ; + eval ' + no warnings ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + +######## +-X +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + no warnings ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default index dd3d182..a8aafee 100644 --- a/contrib/perl5/t/pragma/warn/6default +++ b/contrib/perl5/t/pragma/warn/6default @@ -51,3 +51,71 @@ EXPECT Integer overflow in binary number at - line 3. Illegal binary digit '2' ignored at - line 3. Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. +######## + +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; + my $a = oct "0xfffffffffffffffffg" ; +} +EXPECT + +######## + +# Check scope of pragma with eval +use warnings; +{ + no warnings ; + eval q[ + use warnings ; + my $a = oct "0xfffffffffffffffffg" ; + ]; print STDERR $@; + my $a = oct "0xfffffffffffffffffg" ; +} +EXPECT +Integer overflow in hexadecimal number at (eval 1) line 3. +Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. +Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; +} +EXPECT +Integer overflow in hexadecimal number at (eval 1) line 2. +Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. +Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings; + eval ' + no warnings ; + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@ ; +} +EXPECT + +######## + +# Check scope of pragma with eval +no warnings; +{ + use warnings 'deprecated' ; + eval ' + my $a = oct "0xfffffffffffffffffg" ; + '; print STDERR $@; +} +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal index 943bb06f..ed585c2 100644 --- a/contrib/perl5/t/pragma/warn/7fatal +++ b/contrib/perl5/t/pragma/warn/7fatal @@ -14,6 +14,18 @@ EXPECT Use of EQ is deprecated at - line 8. ######## +# Check compile time warning +use warnings FATAL => 'all' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + # Check runtime scope of pragma use warnings FATAL => 'uninitialized' ; { @@ -27,6 +39,18 @@ Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma +use warnings FATAL => 'all' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma no warnings ; { use warnings FATAL => 'uninitialized' ; @@ -38,6 +62,18 @@ EXPECT Use of uninitialized value in scalar chop at - line 6. ######## +# Check runtime scope of pragma +no warnings ; +{ + use warnings FATAL => 'all' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + --FILE-- abc 1 if $a EQ $b ; 1; @@ -240,3 +276,37 @@ eval ' print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at - line 8. +######## + +use warnings 'void' ; + +time ; + +{ + use warnings FATAL => qw(void) ; + length "abc" ; +} + +join "", 1,2,3 ; + +print "done\n" ; +EXPECT +Useless use of time in void context at - line 4. +Useless use of length in void context at - line 8. +######## + +use warnings ; + +time ; + +{ + use warnings FATAL => qw(void) ; + length "abc" ; +} + +join "", 1,2,3 ; + +print "done\n" ; +EXPECT +Useless use of time in void context at - line 4. +Useless use of length in void context at - line 8. diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled index 7facf99..f5579b2 100755 --- a/contrib/perl5/t/pragma/warn/9enabled +++ b/contrib/perl5/t/pragma/warn/9enabled @@ -332,7 +332,17 @@ print $@ ; EXPECT Usage: warnings::warn([category,] 'message') at - line 4 unknown warnings category 'fred' at - line 6 - require 0 called at - line 6 +######## + +# check warnings::warnif +use warnings ; +eval { warnings::warnif() } ; +print $@ ; +eval { warnings::warnif("fred", "joe") } ; +print $@ ; +EXPECT +Usage: warnings::warnif([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 ######## --FILE-- abc.pm @@ -373,6 +383,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -388,6 +399,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -431,7 +443,37 @@ use warnings 'syntax' ; use abc ; abc::check() ; EXPECT -package 'abc' not registered for warnings at - line 3 +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warn("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warnif("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 ######## --FILE-- abc.pm @@ -617,6 +659,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -632,6 +675,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -723,6 +767,10 @@ sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; } 1; --FILE-- @@ -817,3 +865,298 @@ abc all not enabled def self enabled def abc not enabled def all not enabled +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +BEGIN { $^W = 1 ; } +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +$^W = 1 ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +$| = 1; +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- +use abc ; +use warnings 'abc'; +abc::in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +my message 1 at - line 3 +my message 2 at - line 3 +my message 3 at - line 3 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('def', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +$| = 1; +package abc ; +use def ; +use warnings 'def'; +sub in1 { def::in1() ; } +1; +--FILE-- +use abc ; +no warnings; +abc::in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +my message 1 at abc.pm line 5 + abc::in1() called at - line 3 +my message 2 at abc.pm line 5 + abc::in1() called at - line 3 +my message 3 at abc.pm line 5 + abc::in1() called at - line 3 +######## + +--FILE-- def.pm +$| = 1; +package def ; +no warnings ; +use warnings::register ; +require Exporter; +@ISA = qw( Exporter ) ; +@EXPORT = qw( in1 ) ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('def', "my message 4") ; + warnings::warnif('io', "my message 5") ; + warnings::warnif('all', "my message 6") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +package abc ; +use warnings::register ; +use def ; +#@ISA = qw(def) ; +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +abc::in1() ; +EXPECT +ok2 +ok3 +ok4 +ok5 +my message 1 at - line 4 +my message 3 at - line 4 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; + +sub new +{ + my $class = shift ; + bless [], $class ; +} + +sub check +{ + my $self = shift ; + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + print "ok6\n" if warnings::enabled($self) ; + + warnings::warn("my message 1") ; + warnings::warn($self, "my message 2") ; + + warnings::warnif("my message 3") ; + warnings::warnif('abc', "my message 4") ; + warnings::warnif('def', "my message 5") ; + warnings::warnif('io', "my message 6") ; + warnings::warnif('all', "my message 7") ; + warnings::warnif($self, "my message 8") ; +} +sub in2 +{ + no warnings ; + my $self = shift ; + $self->check() ; +} +sub in1 +{ + no warnings ; + my $self = shift ; + $self->in2(); +} +1; +--FILE-- abc.pm +$| = 1; +package abc ; +use warnings::register ; +use def ; +@ISA = qw(def) ; +sub new +{ + my $class = shift ; + bless [], $class ; +} + +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +$a = new abc ; +$a->in1() ; +print "**\n"; +$b = new def ; +$b->in1() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +ok5 +ok6 +my message 1 at - line 5 +my message 2 at - line 5 +my message 4 at - line 5 +my message 8 at - line 5 +** +ok1 +ok2 +ok3 +ok4 +ok5 +my message 1 at - line 8 +my message 2 at - line 8 +my message 4 at - line 8 diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio index bd40972..2a357e2 100644 --- a/contrib/perl5/t/pragma/warn/doio +++ b/contrib/perl5/t/pragma/warn/doio @@ -12,22 +12,22 @@ warn(warn_nl, "open"); [Perl_do_open9] open(F, "true\ncd") - Close on unopened file <%s> [Perl_do_close] <<TODO + close() on unopened filehandle %s [Perl_do_close] $a = "fred";close("$a") - tell() on unopened file [Perl_do_tell] + tell() on closed filehandle [Perl_do_tell] $a = "fred";$a = tell($a) - seek() on unopened file [Perl_do_seek] + seek() on closed filehandle [Perl_do_seek] $a = "fred";$a = seek($a,1,1) - sysseek() on unopened file [Perl_do_sysseek] + sysseek() on closed filehandle [Perl_do_sysseek] $a = "fred";$a = seek($a,1,1) warn(warn_uninit); [Perl_do_print] print $a ; - Stat on unopened file <%s> [Perl_my_stat] + -x on closed filehandle %s [Perl_my_stat] close STDIN ; -x STDIN ; warn(warn_nl, "stat"); [Perl_my_stat] @@ -96,7 +96,7 @@ close "fred" ; no warnings 'unopened' ; close "joe" ; EXPECT -Close on unopened file <fred> at - line 3. +close() on unopened filehandle fred at - line 3. ######## # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] use warnings 'io' ; @@ -105,17 +105,35 @@ tell(STDIN); $a = seek(STDIN,1,1); $a = sysseek(STDIN,1,1); -x STDIN ; +stat(STDIN) ; +$a = "fred"; +tell($a); +seek($a,1,1); +sysseek($a,1,1); +-x $a; # ok +stat($a); # ok no warnings 'io' ; close STDIN ; tell(STDIN); $a = seek(STDIN,1,1); $a = sysseek(STDIN,1,1); -x STDIN ; +stat(STDIN) ; +$a = "fred"; +tell($a); +seek($a,1,1); +sysseek($a,1,1); +-x $a; +stat($a); EXPECT -tell() on unopened file at - line 4. -seek() on unopened file at - line 5. -sysseek() on unopened file at - line 6. -Stat on unopened file <STDIN> at - line 7. +tell() on closed filehandle STDIN at - line 4. +seek() on closed filehandle STDIN at - line 5. +sysseek() on closed filehandle STDIN at - line 6. +-x on closed filehandle STDIN at - line 7. +stat() on closed filehandle STDIN at - line 8. +tell() on unopened filehandle at - line 10. +seek() on unopened filehandle at - line 11. +sysseek() on unopened filehandle at - line 12. ######## # doio.c [Perl_do_print] use warnings 'uninitialized' ; @@ -188,4 +206,4 @@ my $a = eof STDOUT ; no warnings 'io' ; $a = eof STDOUT ; EXPECT -Filehandle main::STDOUT opened only for output at - line 3. +Filehandle STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op index 1a79b4a..1f41a98 100644 --- a/contrib/perl5/t/pragma/warn/op +++ b/contrib/perl5/t/pragma/warn/op @@ -150,6 +150,17 @@ EXPECT # op.c use warnings 'closure' ; sub x { + our $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c +use warnings 'closure' ; +sub x { my $x; sub y { sub { $x } @@ -267,7 +278,7 @@ Useless use of hash element in void context at - line 29. Useless use of hash slice in void context at - line 30. Useless use of unpack in void context at - line 31. Useless use of pack in void context at - line 32. -Useless use of join in void context at - line 33. +Useless use of join or string in void context at - line 33. Useless use of list slice in void context at - line 34. Useless use of sort in void context at - line 37. Useless use of reverse in void context at - line 38. @@ -558,7 +569,7 @@ Useless use of a constant in void context at - line 3. Useless use of a constant in void context at - line 4. ######## # op.c -BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak +# use warnings 'misc' ; my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ; @@ -592,7 +603,6 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; EXPECT Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. Applying substitution (s///) to @array will act on scalar(@array) at - line 6. -Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. Applying substitution (s///) to @array will act on scalar(@array) at - line 9. @@ -603,6 +613,7 @@ Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13 Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. +Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" BEGIN not safe after errors--compilation aborted at - line 18. ######## # op.c diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl index 4580749..b4a00ba 100644 --- a/contrib/perl5/t/pragma/warn/perl +++ b/contrib/perl5/t/pragma/warn/perl @@ -54,4 +54,19 @@ Name "main::z" used only once: possible typo at - line 6. use warnings 'once' ; $x = 3 ; EXPECT +######## +# perl.c +{ use warnings 'once' ; $x = 3 ; } +$y = 3 ; +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## + +# perl.c +$z = 3 ; +BEGIN { $^W = 1 } +{ no warnings 'once' ; $x = 3 ; } +$y = 3 ; +EXPECT +Name "main::y" used only once: possible typo at - line 6. diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl index 0deccd3..ac01f27 100644 --- a/contrib/perl5/t/pragma/warn/pp_ctl +++ b/contrib/perl5/t/pragma/warn/pp_ctl @@ -214,4 +214,17 @@ DESTROY { die "@{$_[0]} foo bar" } { bless ['A'], 'Foo' for 1..10 } { bless ['B'], 'Foo' for 1..10 } EXPECT - +######## +# pp_ctl.c +use warnings; +eval 'print $foo'; +EXPECT +Use of uninitialized value in print at (eval 1) line 1. +######## +# pp_ctl.c +use warnings; +{ + no warnings; + eval 'print $foo'; +} +EXPECT diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot index 2759057..698255c 100644 --- a/contrib/perl5/t/pragma/warn/pp_hot +++ b/contrib/perl5/t/pragma/warn/pp_hot @@ -1,6 +1,6 @@ pp_hot.c - Filehandle %s never opened [pp_print] + print() on unopened filehandle abc [pp_print] $f = $a = "abc" ; print $f $a Filehandle %s opened only for input [pp_print] @@ -33,6 +33,9 @@ readline() on closed filehandle %s [Perl_do_readline] close STDIN ; $a = <STDIN>; + readline() on closed filehandle %s [Perl_do_readline] + readline(NONESUCH); + glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] @@ -52,7 +55,7 @@ print $f $a; no warnings 'unopened' ; print $f $a; EXPECT -Filehandle main::abc never opened at - line 4. +print() on unopened filehandle abc at - line 4. ######## # pp_hot.c [pp_print] use warnings 'io' ; @@ -71,12 +74,12 @@ print getc(FOO); no warnings 'io' ; print STDIN "anc"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. -Filehandle main::STDOUT opened only for output at - line 4. -Filehandle main::STDERR opened only for output at - line 5. -Filehandle main::FOO opened only for output at - line 6. -Filehandle main::STDERR opened only for output at - line 7. -Filehandle main::FOO opened only for output at - line 8. +Filehandle STDIN opened only for input at - line 3. +Filehandle STDOUT opened only for output at - line 4. +Filehandle STDERR opened only for output at - line 5. +Filehandle FOO opened only for output at - line 6. +Filehandle STDERR opened only for output at - line 7. +Filehandle FOO opened only for output at - line 8. ######## # pp_hot.c [pp_print] use warnings 'closed' ; @@ -90,9 +93,9 @@ print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; EXPECT -print() on closed filehandle main::STDIN at - line 4. -print() on closed filehandle main::STDIN at - line 6. - (Are you trying to call print() on dirhandle main::STDIN?) +print() on closed filehandle STDIN at - line 4. +print() on closed filehandle STDIN at - line 6. + (Are you trying to call print() on dirhandle STDIN?) ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; @@ -137,9 +140,9 @@ no warnings 'closed' ; opendir STDIN, "." ; $a = <STDIN> ; $a = <STDIN> ; EXPECT -readline() on closed filehandle main::STDIN at - line 3. -readline() on closed filehandle main::STDIN at - line 4. - (Are you trying to call readline() on dirhandle main::STDIN?) +readline() on closed filehandle STDIN at - line 3. +readline() on closed filehandle STDIN at - line 4. + (Are you trying to call readline() on dirhandle STDIN?) ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; @@ -148,9 +151,10 @@ open (FH, ">./xcv") ; my $a = <FH> ; no warnings 'io' ; $a = <FH> ; +close (FH) ; unlink $file ; EXPECT -Filehandle main::FH opened only for output at - line 5. +Filehandle FH opened only for output at - line 5. ######## # pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys index 7c38727..68518e2 100644 --- a/contrib/perl5/t/pragma/warn/pp_sys +++ b/contrib/perl5/t/pragma/warn/pp_sys @@ -16,7 +16,7 @@ page overflow [pp_leavewrite] - Filehandle %s never opened [pp_prtf] + printf() on unopened filehandle abc [pp_prtf] $a = "abc"; printf $a "fred" Filehandle %s opened only for input [pp_prtf] @@ -69,13 +69,16 @@ getpeername STDIN; flock() on closed socket %s [pp_flock] + flock() on closed socket [pp_flock] close STDIN; flock STDIN, 8; + flock $a, 8; warn(warn_nl, "stat"); [pp_stat] - Test on unopened file <%s> - close STDIN ; -T STDIN ; + -T on closed filehandle %s + stat() on closed filehandle %s + close STDIN ; -T STDIN ; stat(STDIN) ; warn(warn_nl, "open"); [pp_fttext] -T "abc\ndef" ; @@ -107,7 +110,7 @@ write STDIN; no warnings 'io' ; write STDIN; EXPECT -Filehandle main::STDIN opened only for input at - line 5. +Filehandle STDIN opened only for input at - line 5. ######## # pp_sys.c [pp_leavewrite] use warnings 'closed' ; @@ -123,9 +126,9 @@ write STDIN; opendir STDIN, "."; write STDIN; EXPECT -write() on closed filehandle main::STDIN at - line 6. -write() on closed filehandle main::STDIN at - line 8. - (Are you trying to call write() on dirhandle main::STDIN?) +write() on closed filehandle STDIN at - line 6. +write() on closed filehandle STDIN at - line 8. + (Are you trying to call write() on dirhandle STDIN?) ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; @@ -152,7 +155,7 @@ printf $a "fred"; no warnings 'unopened' ; printf $a "fred"; EXPECT -Filehandle main::abc never opened at - line 4. +printf() on unopened filehandle abc at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'closed' ; @@ -166,9 +169,9 @@ printf STDIN "fred"; opendir STDIN, "."; printf STDIN "fred"; EXPECT -printf() on closed filehandle main::STDIN at - line 4. -printf() on closed filehandle main::STDIN at - line 6. - (Are you trying to call printf() on dirhandle main::STDIN?) +printf() on closed filehandle STDIN at - line 4. +printf() on closed filehandle STDIN at - line 6. + (Are you trying to call printf() on dirhandle STDIN?) ######## # pp_sys.c [pp_prtf] use warnings 'io' ; @@ -176,7 +179,7 @@ printf STDIN "fred"; no warnings 'io' ; printf STDIN "fred"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. +Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] use warnings 'closed' ; @@ -190,14 +193,16 @@ syswrite STDIN, "fred", 1; opendir STDIN, "."; syswrite STDIN, "fred", 1; EXPECT -syswrite() on closed filehandle main::STDIN at - line 4. -syswrite() on closed filehandle main::STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle main::STDIN?) +syswrite() on closed filehandle STDIN at - line 4. +syswrite() on closed filehandle STDIN at - line 6. + (Are you trying to call syswrite() on dirhandle STDIN?) ######## # pp_sys.c [pp_flock] use Config; BEGIN { - if ( $^O eq 'VMS' and ! $Config{d_flock}) { + if ( !$Config{d_flock} && + !$Config{d_fcntl_can_lock} && + !$Config{d_lockf} ) { print <<EOM ; SKIPPED # flock not present @@ -205,19 +210,25 @@ EOM exit ; } } -use warnings 'closed' ; +use warnings qw(unopened closed); close STDIN; flock STDIN, 8; opendir STDIN, "."; flock STDIN, 8; -no warnings 'closed' ; +flock FOO, 8; +flock $a, 8; +no warnings qw(unopened closed); flock STDIN, 8; opendir STDIN, "."; flock STDIN, 8; +flock FOO, 8; +flock $a, 8; EXPECT -flock() on closed filehandle main::STDIN at - line 14. -flock() on closed filehandle main::STDIN at - line 16. - (Are you trying to call flock() on dirhandle main::STDIN?) +flock() on closed filehandle STDIN at - line 16. +flock() on closed filehandle STDIN at - line 18. + (Are you trying to call flock() on dirhandle STDIN?) +flock() on unopened filehandle FOO at - line 19. +flock() on unopened filehandle at - line 20. ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; @@ -285,36 +296,36 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; EXPECT -send() on closed socket main::STDIN at - line 22. -bind() on closed socket main::STDIN at - line 23. -connect() on closed socket main::STDIN at - line 24. -listen() on closed socket main::STDIN at - line 25. -accept() on closed socket main::STDIN at - line 26. -shutdown() on closed socket main::STDIN at - line 27. -setsockopt() on closed socket main::STDIN at - line 28. -getsockopt() on closed socket main::STDIN at - line 29. -getsockname() on closed socket main::STDIN at - line 30. -getpeername() on closed socket main::STDIN at - line 31. -send() on closed socket main::STDIN at - line 33. - (Are you trying to call send() on dirhandle main::STDIN?) -bind() on closed socket main::STDIN at - line 34. - (Are you trying to call bind() on dirhandle main::STDIN?) -connect() on closed socket main::STDIN at - line 35. - (Are you trying to call connect() on dirhandle main::STDIN?) -listen() on closed socket main::STDIN at - line 36. - (Are you trying to call listen() on dirhandle main::STDIN?) -accept() on closed socket main::STDIN at - line 37. - (Are you trying to call accept() on dirhandle main::STDIN?) -shutdown() on closed socket main::STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle main::STDIN?) -setsockopt() on closed socket main::STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle main::STDIN?) -getsockopt() on closed socket main::STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle main::STDIN?) -getsockname() on closed socket main::STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle main::STDIN?) -getpeername() on closed socket main::STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle main::STDIN?) +send() on closed socket STDIN at - line 22. +bind() on closed socket STDIN at - line 23. +connect() on closed socket STDIN at - line 24. +listen() on closed socket STDIN at - line 25. +accept() on closed socket STDIN at - line 26. +shutdown() on closed socket STDIN at - line 27. +setsockopt() on closed socket STDIN at - line 28. +getsockopt() on closed socket STDIN at - line 29. +getsockname() on closed socket STDIN at - line 30. +getpeername() on closed socket STDIN at - line 31. +send() on closed socket STDIN at - line 33. + (Are you trying to call send() on dirhandle STDIN?) +bind() on closed socket STDIN at - line 34. + (Are you trying to call bind() on dirhandle STDIN?) +connect() on closed socket STDIN at - line 35. + (Are you trying to call connect() on dirhandle STDIN?) +listen() on closed socket STDIN at - line 36. + (Are you trying to call listen() on dirhandle STDIN?) +accept() on closed socket STDIN at - line 37. + (Are you trying to call accept() on dirhandle STDIN?) +shutdown() on closed socket STDIN at - line 38. + (Are you trying to call shutdown() on dirhandle STDIN?) +setsockopt() on closed socket STDIN at - line 39. + (Are you trying to call setsockopt() on dirhandle STDIN?) +getsockopt() on closed socket STDIN at - line 40. + (Are you trying to call getsockopt() on dirhandle STDIN?) +getsockname() on closed socket STDIN at - line 41. + (Are you trying to call getsockname() on dirhandle STDIN?) +getpeername() on closed socket STDIN at - line 42. + (Are you trying to call getpeername() on dirhandle STDIN?) ######## # pp_sys.c [pp_stat] use warnings 'newline' ; @@ -325,13 +336,22 @@ EXPECT Unsuccessful stat on filename containing newline at - line 3. ######## # pp_sys.c [pp_fttext] -use warnings 'unopened' ; +use warnings qw(unopened closed) ; close STDIN ; -T STDIN ; -no warnings 'unopened' ; +stat(STDIN) ; +-T HOCUS; +stat(POCUS); +no warnings qw(unopened closed) ; -T STDIN ; +stat(STDIN); +-T HOCUS; +stat(POCUS); EXPECT -Test on unopened file <STDIN> at - line 4. +-T on closed filehandle STDIN at - line 4. +stat() on closed filehandle STDIN at - line 5. +-T on unopened filehandle HOCUS at - line 6. +stat() on unopened filehandle POCUS at - line 7. ######## # pp_sys.c [pp_fttext] use warnings 'newline' ; @@ -343,6 +363,13 @@ Unsuccessful open on filename containing newline at - line 3. ######## # pp_sys.c [pp_sysread] use warnings 'io' ; +if ($^O eq 'dos') { + print <<EOM ; +SKIPPED +# skipped on dos +EOM + exit ; +} my $file = "./xcv" ; open(F, ">$file") ; my $a = sysread(F, $a,10) ; @@ -351,4 +378,4 @@ my $a = sysread(F, $a,10) ; close F ; unlink $file ; EXPECT -Filehandle main::F opened only for output at - line 5. +Filehandle F opened only for output at - line 12. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp index 5d0c291..8b86b50 100644 --- a/contrib/perl5/t/pragma/warn/regcomp +++ b/contrib/perl5/t/pragma/warn/regcomp @@ -11,10 +11,6 @@ Character class [:%.*s:] unknown [S_regpposixcc] - Character class syntax [. .] is reserved for future extensions [S_regpposixcc] - - Character class syntax [= =] is reserved for future extensions [S_checkposixcc] - Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] @@ -33,7 +29,7 @@ $a =~ /(?=a)*/ ; no warnings 'regexp' ; $a =~ /(?=a)*/ ; EXPECT -(?=a)* matches null string many times at - line 4. +(?=a)* matches null string many times before HERE mark in regex m/(?=a)* << HERE / at - line 4. ######## # regcomp.c [S_study_chunk] use warnings 'regexp' ; @@ -42,7 +38,7 @@ $_ = "" ; no warnings 'regexp' ; /(?=a)?/; EXPECT -Strange *+?{} on zero-length expression at - line 4. +Quantifier unexpected on zero-length expression before HERE mark in regex m/(?=a)? << HERE / at - line 4. ######## # regcomp.c [S_regatom] $x = '\m' ; @@ -51,39 +47,44 @@ $a =~ /a$x/ ; no warnings 'regexp' ; $a =~ /a$x/ ; EXPECT -/a\m/: Unrecognized escape \m passed through at - line 4. +Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4. ######## # regcomp.c [S_regpposixcc S_checkposixcc] -BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +# use warnings 'regexp' ; $_ = "" ; /[:alpha:]/; -/[.bar.]/; -/[=zog=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; /[:zog:]/; /[[:zog:]]/; no warnings 'regexp' ; /[:alpha:]/; -/[.foo.]/; -/[=bar=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; -/[[:zog:]]/; /[:zog:]/; +/[[:zog:]]/; EXPECT -Character class syntax [: :] belongs inside character classes at - line 5. -Character class syntax [. .] belongs inside character classes at - line 6. -Character class syntax [. .] is reserved for future extensions at - line 6. -Character class syntax [= =] belongs inside character classes at - line 7. -Character class syntax [= =] is reserved for future extensions at - line 7. -Character class syntax [. .] is reserved for future extensions at - line 9. -Character class syntax [= =] is reserved for future extensions at - line 10. -Character class syntax [: :] belongs inside character classes at - line 11. -Character class [:zog:] unknown at - line 12. +POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:alpha:] << HERE / at - line 5. +POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:zog:] << HERE / at - line 6. +POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/ +######## +# regcomp.c [S_checkposixcc] +# +use warnings 'regexp' ; +$_ = "" ; +/[.zog.]/; +no warnings 'regexp' ; +/[.zog.]/; +EXPECT +POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/[.zog.] << HERE / at - line 5. +POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE / +######## +# regcomp.c [S_checkposixcc] +# +use warnings 'regexp' ; +$_ = "" ; +/[[.zog.]]/; +no warnings 'regexp' ; +/[[.zog.]]/; +EXPECT +POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[[.zog.] << HERE ]/ ######## # regcomp.c [S_regclass] $_ = ""; @@ -108,14 +109,14 @@ no warnings 'regexp' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[a-\d]/: false [] range "a-\d" in regexp at - line 5. -/[\d-b]/: false [] range "\d-" in regexp at - line 6. -/[\s-\d]/: false [] range "\s-" in regexp at - line 7. -/[\d-\s]/: false [] range "\d-" in regexp at - line 8. -/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9. -/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10. -/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11. -/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. +False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 5. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 6. +False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 7. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 8. +False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 9. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 10. +False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 11. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 12. ######## # regcomp.c [S_regclassutf8] BEGIN { @@ -147,14 +148,14 @@ no warnings 'regexp' ; /[[:alpha:]-[:digit:]]/; /[[:digit:]-[:alpha:]]/; EXPECT -/[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. +False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 12. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 13. +False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 14. +False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 15. +False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 16. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 17. +False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 18. +False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 19. ######## # regcomp.c [S_regclass S_regclassutf8] use warnings 'regexp' ; @@ -162,4 +163,5 @@ $a =~ /[a\zb]/ ; no warnings 'regexp' ; $a =~ /[a\zb]/ ; EXPECT -/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3. +Unrecognized escape \z in character class passed through before HERE mark in regex m/[a\z << HERE b]/ at - line 3. + diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv index 758137f..2409589 100644 --- a/contrib/perl5/t/pragma/warn/sv +++ b/contrib/perl5/t/pragma/warn/sv @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value in concatenation (.) at - line 10. +Use of uninitialized value in concatenation (.) or string at - line 10. ######## # sv.c use warnings 'numeric' ; diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke index cfdea78..fa71329 100644 --- a/contrib/perl5/t/pragma/warn/toke +++ b/contrib/perl5/t/pragma/warn/toke @@ -198,10 +198,6 @@ EXPECT Semicolon seems to be missing at - line 3. ######## # toke.c -BEGIN { - # Scalars leaked: due to syntax errors - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} use warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; @@ -214,25 +210,21 @@ $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT -Reversed += operator at - line 7. -Reversed -= operator at - line 8. -Reversed *= operator at - line 9. -Reversed %= operator at - line 10. -Reversed &= operator at - line 11. -Reversed .= operator at - line 12. -syntax error at - line 12, near "=." -Reversed ^= operator at - line 13. -syntax error at - line 13, near "=^" -Reversed |= operator at - line 14. -syntax error at - line 14, near "=|" -Reversed <= operator at - line 15. -Unterminated <> operator at - line 15. -######## -# toke.c -BEGIN { - # Scalars leaked: due to syntax errors - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} +Reversed += operator at - line 3. +Reversed -= operator at - line 4. +Reversed *= operator at - line 5. +Reversed %= operator at - line 6. +Reversed &= operator at - line 7. +Reversed .= operator at - line 8. +Reversed ^= operator at - line 9. +Reversed |= operator at - line 10. +Reversed <= operator at - line 11. +syntax error at - line 8, near "=." +syntax error at - line 9, near "=^" +syntax error at - line 10, near "=|" +Unterminated <> operator at - line 11. +######## +# toke.c no warnings 'syntax' ; my $a =+ 2 ; $a =- 2 ; @@ -245,10 +237,10 @@ $a =| 2 ; $a =< 2 ; $a =/ 2 ; EXPECT -syntax error at - line 12, near "=." -syntax error at - line 13, near "=^" -syntax error at - line 14, near "=|" -Unterminated <> operator at - line 15. +syntax error at - line 8, near "=." +syntax error at - line 9, near "=^" +syntax error at - line 10, near "=|" +Unterminated <> operator at - line 11. ######## # toke.c use warnings 'syntax' ; @@ -290,6 +282,9 @@ Can't use \1 to mean $1 in expression at - line 4. # toke.c use warnings 'reserved' ; $a = abc; +$a = { def + +=> 1 }; no warnings 'reserved' ; $a = abc; EXPECT @@ -434,13 +429,14 @@ Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. # toke.c use warnings ; eval <<'EOE'; +# line 30 "foo" +warn "yelp"; { -#line 30 "foo" $_ = " \x{123} " ; } EOE EXPECT - +yelp at foo line 30. ######## # toke.c my $a = rand + 4 ; @@ -581,3 +577,11 @@ EXPECT Integer overflow in binary number at - line 5. Integer overflow in hexadecimal number at - line 8. Integer overflow in octal number at - line 11. +######## +# toke.c +use warnings 'ambiguous'; +"@mjd_previously_unused_array"; +no warnings 'ambiguous'; +"@mjd_previously_unused_array"; +EXPECT +Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8 index 6a2fe54..9a7dbaf 100644 --- a/contrib/perl5/t/pragma/warn/utf8 +++ b/contrib/perl5/t/pragma/warn/utf8 @@ -15,6 +15,12 @@ __END__ # utf8.c [utf8_to_uv] -W +BEGIN { + if (ord('A') == 193) { + print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; + exit 0; + } +} use utf8 ; my $a = "snøstorm" ; { @@ -24,6 +30,6 @@ my $a = "snøstorm" ; my $a = "snøstorm"; } EXPECT -Malformed UTF-8 character at - line 3. -Malformed UTF-8 character at - line 8. +Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9. +Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14. ######## diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t index 71fb0df..66b4ff9 100755 --- a/contrib/perl5/t/pragma/warnings.t +++ b/contrib/perl5/t/pragma/warnings.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; require Config; import Config; } @@ -26,9 +26,7 @@ else foreach (@w_files) { - next if /\.orig$/ ; - - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { |
