diff options
| author | Charles Bailey <bailey@newman.upenn.edu> | 2001-01-08 08:53:52 +0000 |
|---|---|---|
| committer | bailey <bailey@newman.upenn.edu> | 2001-01-08 08:53:52 +0000 |
| commit | 0e06870bf080a38cda51c06c6612359afc2334e1 (patch) | |
| tree | 763f11122a3b18bc443e808010b970428ab57432 /t | |
| parent | e3830a4ec012ee625f1b3bc63b5b18c656f377da (diff) | |
| download | perl-0e06870bf080a38cda51c06c6612359afc2334e1.tar.gz | |
Once again syncing after too long an absence
p4raw-id: //depot/vmsperl@8367
Diffstat (limited to 't')
92 files changed, 4259 insertions, 607 deletions
@@ -1,4 +1,4 @@ -This is the perl test library. To run all the tests, just type 'TEST'. +This is the perl test library. To run all the tests, just type './TEST'. To add new tests, just look at the current tests and do likewise. @@ -14,3 +14,8 @@ will fail, you may want to use Test::Harness thusly: This method pinpoints failed tests automatically. If you come up with new tests, please send them to perlbug@perl.org. + +Tests in the base/ directory ought to be runnable with plain miniperl. +That is, they should not require Config.pm nor should they require any +extensions to have been built. TEST will abort if any tests in the +base/ directory fail. @@ -114,6 +114,9 @@ EOT $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { $next = $next + 1; + } + elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); } else { $ok = 0; @@ -127,6 +127,9 @@ EOT $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { $next = $next + 1; + } + elsif (/^Bail out!\s*(.*)/i) { # magic words + die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); } else { $ok = 0; diff --git a/t/base/commonsense.t b/t/base/commonsense.t new file mode 100644 index 0000000000..6e313073d2 --- /dev/null +++ b/t/base/commonsense.t @@ -0,0 +1,25 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = '../lib'; +require Config; import Config; +if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "Bail out! Perl configured without DB_File or [A-Z]DBM_File\n"; + exit 0; +} +if (($Config{'extensions'} !~ /\bFcntl\b/) ){ + print "Bail out! Perl configured without Fcntl module\n"; + exit 0; +} +if (($Config{'extensions'} !~ /\bIO\b/) ){ + print "Bail out! Perl configured without IO module\n"; + exit 0; +} +# hey, DOS users do not need this kind of common sense ;-) +if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){ + print "Bail out! Perl configured without File::Glob module\n"; + exit 0; +} + +print "1..1\nok 1\n"; + diff --git a/t/base/term.t b/t/base/term.t index e96313dec5..49df11fa31 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -4,19 +4,16 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; } -use Config; - print "1..7\n"; # check "" interpretation $x = "\n"; # 10 is ASCII/Iso Latin, 21 is EBCDIC. -if ($x eq chr(10) || - ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";} +if ($x eq chr(10)) { print "ok 1\n";} +elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; } else {print "not ok 1\n";} # check `` processing diff --git a/t/comp/proto.t b/t/comp/proto.t index f9731ee489..874ab44058 100755 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -9,6 +9,9 @@ # we should test as many as we can. # +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; @@ -16,7 +19,7 @@ BEGIN { use strict; -print "1..110\n"; +print "1..124\n"; my $i = 1; @@ -340,6 +343,7 @@ sub sub_array (&@) { @array = (qw(O K)," ", $i++); sub_array { lc shift } @array; +sub_array { lc shift } ('O', 'K', ' ', $i++); print "\n"; ## @@ -485,3 +489,17 @@ 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; + print "# eval[$eval]\nnot " unless $@ && $@ =~ /syntax error/; + print "ok ", $i++, "\n"; +} + +# Not $$;$;$ +print "not " unless prototype "CORE::substr" eq '$$;$$'; +print "ok ", $i++, "\n"; diff --git a/t/comp/redef.t b/t/comp/redef.t index 07e978bb86..328b44d3c8 100755 --- a/t/comp/redef.t +++ b/t/comp/redef.t @@ -11,7 +11,7 @@ sub ok ($$) { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } -print "1..18\n"; +print "1..20\n"; my $NEWPROTO = 'Prototype mismatch:'; @@ -72,9 +72,15 @@ sub sub9 ($) { 2 } ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; -ok 18, $_ eq ''; +BEGIN { + local $^W = 0; + eval qq(sub sub10 () {1} sub sub10 {1}); +} -# If we got any errors that we were not expecting, then print them -print $_ if length $_; +ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s; +ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s; +ok 20, $warn eq ''; +# If we got any errors that we were not expecting, then print them +print $warn if length $warn; diff --git a/t/comp/require.t b/t/comp/require.t index eaea3ad5f6..e634532275 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -21,6 +21,7 @@ sub write_file { my $f = shift; open(REQ,">$f") or die "Can't write '$f': $!"; binmode REQ; + use bytes; print REQ @_; close REQ; } @@ -132,7 +133,7 @@ $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; + return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; } $i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE diff --git a/t/io/dup.t b/t/io/dup.t index af13d4d8f7..9b656ec8b3 100755 --- a/t/io/dup.t +++ b/t/io/dup.t @@ -2,7 +2,7 @@ # $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $ -print "1..6\n"; +print "1..8\n"; print "ok 1\n"; @@ -17,14 +17,10 @@ select(STDOUT); $| = 1; print STDOUT "ok 2\n"; print STDERR "ok 3\n"; -if ($^O eq 'MSWin32') { print `echo ok 4`; print `echo ok 5 1>&2`; # does this work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} + system 'echo ok 6'; + system 'echo ok 7 1>&2'; close(STDOUT); close(STDERR); @@ -36,5 +32,5 @@ if ($^O eq 'MSWin32') { print `type Io.dup` } else { system 'cat Io.dup' } unlink 'Io.dup'; -print STDOUT "ok 6\n"; +print STDOUT "ok 8\n"; @@ -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/t/io/open.t b/t/io/open.t index 01902812e2..0e2d57cd75 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -9,6 +9,7 @@ BEGIN { $| = 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) { + 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) { + 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/t/io/pipe.t b/t/io/pipe.t index 96935e3f88..500832595e 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -11,7 +11,7 @@ BEGIN { } $| = 1; -print "1..15\n"; +print "1..16\n"; # External program 'tr' assumed. open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); @@ -99,12 +99,23 @@ else { local $SIG{PIPE} = 'IGNORE'; open NIL, '|true' or die "open failed: $!"; sleep 5; - print NIL 'foo' or die "print failed: $!"; - if (close NIL) { - print "not ok 9\n"; + if (print NIL 'foo') { + # If print was allowed we had better get an error on close + if (close NIL) { + print "not ok 9\n"; + } + else { + print "ok 9\n"; + } } else { - print "ok 9\n"; + # If print failed, the close should be clean + if (close NIL) { + print "ok 9\n"; + } + else { + print "not ok 9\n"; + } } } @@ -174,3 +185,20 @@ if ($? != 42) { } print "ok 15\n"; $? = 0; + +# check that child is reaped if the piped program can't be executed +{ + open NIL, '/no_such_process |'; + close NIL; + + my $child = 0; + eval { + local $SIG{ALRM} = sub { die; }; + alarm 2; + $child = wait; + alarm 0; + }; + + print "not " if $child != -1; + print "ok 16\n"; +} diff --git a/t/io/tell.t b/t/io/tell.t index b89aefb230..560836d5e0 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -2,7 +2,7 @@ # $RCSfile: tell.t,v $$Revision$$Date$ -print "1..21\n"; +print "1..23\n"; $TST = 'tst'; @@ -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/t/io/utf8.t b/t/io/utf8.t new file mode 100755 index 0000000000..04554e7797 --- /dev/null +++ b/t/io/utf8.t @@ -0,0 +1,163 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'useperlio'}) { + print "1..0 # Skip: not perlio\n"; + exit 0; + } +} + +$| = 1; +print "1..25\n"; + +open(F,"+>:utf8",'a'); +print F chr(0x100).'£'; +print '#'.tell(F)."\n"; +print "not " unless tell(F) == 4; +print "ok 1\n"; +print F "\n"; +print '#'.tell(F)."\n"; +print "not " unless tell(F) >= 5; +print "ok 2\n"; +seek(F,0,0); +print "not " unless getc(F) eq chr(0x100); +print "ok 3\n"; +print "not " unless getc(F) eq "£"; +print "ok 4\n"; +print "not " unless getc(F) eq "\n"; +print "ok 5\n"; +seek(F,0,0); +binmode(F,":bytes"); +print "not " unless getc(F) eq chr(0xc4); +print "ok 6\n"; +print "not " unless getc(F) eq chr(0x80); +print "ok 7\n"; +print "not " unless getc(F) eq chr(0xc2); +print "ok 8\n"; +print "not " unless getc(F) eq chr(0xa3); +print "ok 9\n"; +print "not " unless getc(F) eq "\n"; +print "ok 10\n"; +seek(F,0,0); +binmode(F,":utf8"); +print "not " unless scalar(<F>) eq "\x{100}£\n"; +print "ok 11\n"; +seek(F,0,0); +$buf = chr(0x200); +$count = read(F,$buf,2,1); +print "not " unless $count == 2; +print "ok 12\n"; +print "not " unless $buf eq "\x{200}\x{100}£"; +print "ok 13\n"; +close(F); + +{ +$a = chr(300); # This *is* UTF-encoded +$b = chr(130); # This is not. + +open F, ">:utf8", 'a' or die $!; +print F $a,"\n"; +close F; + +open F, "<:utf8", 'a' or die $!; +$x = <F>; +chomp($x); +print "not " unless $x eq chr(300); +print "ok 14\n"; + +open F, "a" or die $!; # Not UTF +$x = <F>; +chomp($x); +print "not " unless $x eq chr(196).chr(172); +print "ok 15\n"; +close F; + +open F, ">:utf8", 'a' or die $!; +binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. +print F $a; +my $y; +{ my $x = tell(F); + { use bytes; $y = length($a);} + print "not " unless $x == $y; + print "ok 16\n"; +} + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 1; +print "ok 17\n"; +} + +print F $b,"\n"; # This upgrades $b! + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 2; +print "ok 18\n"; +} + +{ my $x = tell(F); + { use bytes; $y += 3;} + print "not " unless $x == $y; + print "ok 19\n"; +} + +close F; + +open F, "a" or die $!; # Not UTF +$x = <F>; +chomp($x); +print "not " unless $x eq v196.172.194.130; +print "ok 20\n"; + +open F, "<:utf8", "a" or die $!; +$x = <F>; +chomp($x); +close F; +print "not " unless $x eq chr(300).chr(130); +print "ok 21\n"; + +# Now let's make it suffer. +open F, ">", "a" or die $!; +eval { print F $a; }; +print "not " unless $@ and $@ =~ /Wide character in print/i; +print "ok 22\n"; +} + +# Hm. Time to get more evil. +open F, ">:utf8", "a" or die $!; +print F $a; +binmode(F, ":bytes"); +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = <F>; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 23\n"; + +# Right. +open F, ">:utf8", "a" or die $!; +print F $a; +close F; +open F, ">>", "a" or die $!; +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = <F>; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 24\n"; + +# Now we have a deformed file. +open F, "<:utf8", "a" or die $!; +$x = <F>; chomp $x; +{ local $SIG{__WARN__} = sub { print "ok 25\n"; }; +eval { sprintf "%vd\n", $x; } +} + +unlink('a'); + diff --git a/t/lib/attrs.t b/t/lib/attrs.t index 440122c2b4..18a02aba84 100644 --- a/t/lib/attrs.t +++ b/t/lib/attrs.t @@ -11,9 +11,12 @@ BEGIN { } } +use warnings; +no warnings qw(deprecated); # else attrs cries. + sub NTESTS () ; -my $test, $ntests; +my ($test, $ntests); BEGIN {$ntests=0} $test=0; my $failed = 0; @@ -119,7 +122,7 @@ BEGIN {++$ntests} { my $w = "" ; - local $SIG{__WARN__} = sub {$w = @_[0]} ; + local $SIG{__WARN__} = sub {$w = shift} ; eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; (print "not "), $failed=1 if $@; print "ok ",++$test,"\n"; @@ -10,7 +10,7 @@ use warnings; use strict; use Config; -print "1..13\n"; +print "1..17\n"; my $test = 1; @@ -53,6 +53,20 @@ print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }}) ok; } +print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42; +ok; + +use constant 'c', 'stuff'; +print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; +ok; + +# XXX ToDo - constsub that returns a reference +#use constant cr => ['hello']; +#my $string = "sub " . $deparse->coderef2text(\&cr); +#my $val = (eval $string)->(); +#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; +#ok; + my $a; my $Is_VMS = $^O eq 'VMS'; $a = `$^X "-I../lib" "-MO=Deparse" -anle 1 2>&1`; @@ -62,26 +76,21 @@ $b = <<'EOF'; LINE: while (defined($_ = <ARGV>)) { chomp $_; @F = split(/\s+/, $_, 0); - '???' -} -continue { - '???' + '???'; } EOF print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; ok; -#6 $a = `$^X "-I../lib" "-MO=Debug" -e 1 2>&1`; print "not " unless $a =~ /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; ok; -#7 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`; print "not " unless $a =~ -/\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s; +/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; ok; $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`; @@ -114,12 +123,13 @@ ok; chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e1`); $a = join ',', sort split /,/, $a; +$a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; $a =~ s/-uWin32,// if $^O eq 'MSWin32'; $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; $a =~ s/-uCwd,// if $^O eq 'cygwin'; if ($Config{static_ext} eq ' ') { $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; + . '-umain,-ustrict,-uwarnings'; print "# [$a] vs [$b]\nnot " if $a ne $b; ok; } else { @@ -133,3 +143,14 @@ if ($is_thread) { print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; } ok; + +# Bug 20001204.07 +{ +my $foo = $deparse->coderef2text(sub { { 234; }}); +# Constants don't get optimised here. +print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; +ok; +$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); +print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; +ok; +} diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t index 20816940c4..b335d13016 100755 --- a/t/lib/bigfltpm.t +++ b/t/lib/bigfltpm.t @@ -449,10 +449,10 @@ $Math::BigFloat::div_scale = 20 $Math::BigFloat::div_scale = 40 &fsqrt +0:0 --1:/^(?i:0|\?|NaNQ?)$ --2:/^(?i:0|\?|NaNQ?)$ --16:/^(?i:0|\?|NaNQ?)$ --123.456:/^(?i:0|\?|NaNQ?)$ +-1:/^(?i:0|\?|-?N\.?aNQ?)$ +-2:/^(?i:0|\?|-?N\.?aNQ?)$ +-16:/^(?i:0|\?|-?N\.?aNQ?)$ +-123.456:/^(?i:0|\?|-?N\.?aNQ?)$ +1:1. +1.44:1.2 +2:1.41421356237309504880168872420969807857 diff --git a/t/lib/cgi-function.t b/t/lib/cgi-function.t index 653c4e55e6..3b9722e3bd 100755 --- a/t/lib/cgi-function.t +++ b/t/lib/cgi-function.t @@ -36,6 +36,11 @@ my $CRLF = "\015\012"; 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'; diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t index 50c840816b..3d3da10b25 100755 --- a/t/lib/cgi-html.t +++ b/t/lib/cgi-html.t @@ -82,7 +82,12 @@ 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/t/lib/class-struct.t b/t/lib/class-struct.t new file mode 100644 index 0000000000..26505bacfc --- /dev/null +++ b/t/lib/class-struct.t @@ -0,0 +1,66 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..8\n"; + +package aClass; + +sub new { bless {}, shift } + +sub meth { 42 } + +package MyObj; + +use Class::Struct; +use Class::Struct 'struct'; # test out both forms + +use Class::Struct SomeClass => { SomeElem => '$' }; + +struct( s => '$', a => '@', h => '%', c => 'aClass' ); + +my $obj = MyObj->new; + +$obj->s('foo'); + +print "not " unless $obj->s() eq 'foo'; +print "ok 1\n"; + +my $arf = $obj->a; + +print "not " unless ref $arf eq 'ARRAY'; +print "ok 2\n"; + +$obj->a(2, 'secundus'); + +print "not " unless $obj->a(2) eq 'secundus'; +print "ok 3\n"; + +my $hrf = $obj->h; + +print "not " unless ref $hrf eq 'HASH'; +print "ok 4\n"; + +$obj->h('x', 10); + +print "not " unless $obj->h('x') == 10; +print "ok 5\n"; + +my $orf = $obj->c; + +print "not " unless ref $orf eq 'aClass'; +print "ok 6\n"; + +print "not " unless $obj->c->meth() == 42; +print "ok 7\n"; + +my $obk = SomeClass->new(); + +$obk->SomeElem(123); + +print "not " unless $obk->SomeElem() == 123; +print "ok 8\n"; + diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index 75c661bbee..1822823563 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -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/t/lib/db-hash.t b/t/lib/db-hash.t index b7018742e4..effc60b7dd 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -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/t/lib/db-recno.t b/t/lib/db-recno.t index 18fb45b114..8b5a88cc6d 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -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/t/lib/dprof.t b/t/lib/dprof.t index 10c9b0fa16..be711f1330 100755 --- a/t/lib/dprof.t +++ b/t/lib/dprof.t @@ -11,7 +11,8 @@ BEGIN { } END { - unlink 'tmon.out', 'err'; + while(-e 'tmon.out' && unlink 'tmon.out') {} + while(-e 'err' && unlink 'err') {} } use Benchmark qw( timediff timestr ); @@ -22,7 +23,7 @@ getopts('vI:p:'); # -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 ); @@ -46,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 ); @@ -56,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; } @@ -72,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/t/lib/dprof/V.pm b/t/lib/dprof/V.pm index 7e34da5d47..cbdeca4eda 100644 --- a/t/lib/dprof/V.pm +++ b/t/lib/dprof/V.pm @@ -13,6 +13,7 @@ $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?" } @@ -21,7 +22,7 @@ if( ! -f $dpp ){ die "Where's dprofpp?" } 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/t/lib/encode.t b/t/lib/encode.t index 568efd31f5..280c2d0ed5 100644 --- a/t/lib/encode.t +++ b/t/lib/encode.t @@ -12,7 +12,11 @@ use Encode qw(from_to); use charnames qw(greek); my @encodings = grep(/iso8859/,Encode::encodings()); my $n = 2; -plan test => 13+$n*@encodings; +my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z'); +my @source = qw(ascii iso8859-1 cp1250); +my @destiny = qw(cp1047 cp37 posix-bc); +my @ebcdic_sets = qw(cp1047 cp37 posix-bc); +plan test => 21+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256; my $str = join('',map(chr($_),0x20..0x7E)); my $cpy = $str; ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); @@ -27,7 +31,7 @@ ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); my $sym = Encode->getEncoding('symbol'); my $uni = $sym->toUnicode('a'); -ok("\N{alpha}",substr($uni,0,1),"alpha does not map so symbol 'a'"); +ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'"); $str = $sym->fromUnicode("\N{Beta}"); ok("B",substr($str,0,1),"Symbol 'B' does not map to Beta"); @@ -41,3 +45,58 @@ foreach my $enc (qw(symbol dingbats ascii),@encodings) ok($cpy,$str,"$enc mangled translating to Unicode and back"); } +# On ASCII based machines see if we can map several codepoints from +# three distinct ASCII sets to three distinct EBCDIC coded character sets. +# On EBCDIC machines see if we can map from three EBCDIC sets to three +# distinct ASCII sets. + +my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169); +if (ord('A') != 65) { + my @temp = @destiny; + @destiny = @source; + @source = @temp; + undef(@temp); + @expectation = (48..57, 65..90, 97..122); +} + +foreach my $to (@destiny) + { + foreach my $from (@source) + { + my @expected = @expectation; + foreach my $chr (@character_set) + { + my $native_chr = $chr; + my $cpy = $chr; + my $rc = from_to($cpy,$from,$to); + ok(1,$rc,"Could not translate from $from to $to"); + ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to"); + } + } + } + +# On either ASCII or EBCDIC machines ensure we can take the full one +# byte repetoire to EBCDIC sets and back. + +my $enc_as = 'iso8859-1'; +foreach my $enc_eb (@ebcdic_sets) + { + foreach my $ord (0..255) + { + $str = chr($ord); + my $rc = from_to($str,$enc_as,$enc_eb); + $rc += from_to($str,$enc_eb,$enc_as); + ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained"); + ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back"); + } + } + +for $i (256,128,129,256) + { + my $c = chr($i); + my $s = "$c\n".sprintf("%02X",$i); + ok(Encode::valid_utf8($s),1,"concat of $i botched"); + Encode::utf8_upgrade($s); + ok(Encode::valid_utf8($s),1,"concat of $i botched"); + } + diff --git a/t/lib/filter-util.pl b/t/lib/filter-util.pl new file mode 100644 index 0000000000..9b29c5ef52 --- /dev/null +++ b/t/lib/filter-util.pl @@ -0,0 +1,48 @@ +sub readFile +{ + my ($filename) = @_ ; + my ($string) = '' ; + + open (F, "<$filename") + or die "Cannot open $filename: $!\n" ; + while (<F>) + { $string .= $_ } + close F ; + $string ; +} + +sub writeFile +{ + my($filename, @strings) = @_ ; + open (F, ">$filename") + or die "Cannot open $filename: $!\n" ; + binmode(F) if $filename =~ /bin$/i; + foreach (@strings) + { print F } + close F ; +} + +sub ok +{ + my($number, $result, $note) = @_ ; + + $note = "" if ! defined $note ; + if ($note) { + $note = "# $note" if $note !~ /^\s*#/ ; + $note =~ s/^\s*/ / ; + } + + print "not " if !$result ; + print "ok ${number}${note}\n"; +} + +$Inc = '' ; +foreach (@INC) + { $Inc .= "\"-I$_\" " } + +$Perl = '' ; +$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; + +$Perl = "$Perl -w" ; + +1; diff --git a/t/lib/filter-util.t b/t/lib/filter-util.t new file mode 100644 index 0000000000..80c8f56a24 --- /dev/null +++ b/t/lib/filter-util.t @@ -0,0 +1,791 @@ +BEGIN { + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) { + print "1..0 # Skip: Filter::Util::Call was not built\n"; + exit 0; + } + require 'lib/filter-util.pl'; +} + +print "1..28\n" ; + +$Perl = "$Perl -w" ; + +use Cwd ; +$here = getcwd ; + +use vars qw($Inc $Perl); + +$filename = "call.tst" ; +$filenamebin = "call.bin" ; +$module = "MyTest" ; +$module2 = "MyTest2" ; +$module3 = "MyTest3" ; +$module4 = "MyTest4" ; +$module5 = "MyTest5" ; +$nested = "nested" ; +$block = "block" ; + +# Test error cases +################## + +# no filter function in module +############################### + +writeFile("${module}.pm", <<EOM) ; +package ${module} ; + +use Filter::Util::Call ; + +sub import { filter_add(bless []) } + +1 ; +EOM + +$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; +ok(1, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; +ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ; + +# no reference parameter in filter_add +###################################### + +writeFile("${module}.pm", <<EOM) ; +package ${module} ; + +use Filter::Util::Call ; + +sub import { filter_add() } + +1 ; +EOM + +$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; +ok(3, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; +#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ; +ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ; + + + + +# non-error cases +################# + + +# a simple filter, using a closure +################# + +writeFile("${module}.pm", <<EOM, <<'EOM') ; +package ${module} ; + +EOM +use Filter::Util::Call ; +sub import { + filter_add( + sub { + + my ($status) ; + + if (($status = filter_read()) > 0) { + s/ABC/DEF/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module ; +EOM + +use Cwd ; +$here = getcwd ; +print "I am $here\n" ; +print "some letters ABC\n" ; +$y = "ABCDEF" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(5, ($? >>8) == 0) ; +ok(6, $a eq <<EOM) ; +I am $here +some letters DEF +Alphabetti Spagetti (DEFDEF) +EOM + +# a simple filter, not using a closure +################# + +writeFile("${module}.pm", <<EOM, <<'EOM') ; +package ${module} ; + +EOM +use Filter::Util::Call ; +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/ABC/DEF/g + } + $status ; +} + + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module ; +EOM + +use Cwd ; +$here = getcwd ; +print "I am $here\n" ; +print "some letters ABC\n" ; +$y = "ABCDEF" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(7, ($? >>8) == 0) ; +ok(8, $a eq <<EOM) ; +I am $here +some letters DEF +Alphabetti Spagetti (DEFDEF) +EOM + + +# nested filters +################ + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/XYZ/PQR/g + } + $status ; +} + +1 ; +EOM + +writeFile("${module3}.pm", <<EOM, <<'EOM') ; +package ${module3} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add( + + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + s/Fred/Joe/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile("${module4}.pm", <<EOM) ; +package ${module4} ; + +use $module5 ; + +print "I'm feeling used!\n" ; +print "Fred Joe ABC DEF PQR XYZ\n" ; +print "See you Today\n" ; +1; +EOM + +writeFile("${module5}.pm", <<EOM, <<'EOM') ; +package ${module5} ; +use Filter::Util::Call ; + +EOM +sub import { filter_add(bless []) } + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/Today/Tomorrow/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; + +# two filters for this file +use $module ; +use $module2 ; +require "$nested" ; +use $module4 ; +EOM + +print "some letters ABCXYZ\n" ; +$y = "ABCDEFXYZ" ; +print <<EOF ; +Fred likes Alphabetti Spagetti ($y) +EOF + +EOM + +writeFile($nested, <<EOM, <<'EOM') ; +use $module3 ; +EOM + +print "This is another file XYZ\n" ; +print <<EOF ; +Where is Fred? +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(9, ($? >>8) == 0) ; +ok(10, $a eq <<EOM) ; +I'm feeling used! +Fred Joe ABC DEF PQR XYZ +See you Tomorrow +This is another file XYZ +Where is Joe? +some letters DEFPQR +Fred likes Alphabetti Spagetti (DEFDEFPQR) +EOM + +# using the module context (with a closure) +########################################### + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add ( + + sub + { + my ($status) ; + my ($pattern) ; + + if (($status = filter_read()) > 0) { + foreach $pattern (@strings) + { s/$pattern/PQR/g } + } + + $status ; + } + ) + +} +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 qw( XYZ KLM) ; +use $module2 qw( ABC NMO) ; +EOM + +print "some letters ABCXYZ KLM NMO\n" ; +$y = "ABCDEFXYZKLMNMO" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(11, ($? >>8) == 0) ; +ok(12, $a eq <<EOM) ; +some letters PQRPQR PQR PQR +Alphabetti Spagetti (PQRDEFPQRPQRPQR) +EOM + + + +# using the module context (without a closure) +############################################## + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add (bless [@strings]) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($pattern) ; + + if (($status = filter_read()) > 0) { + foreach $pattern (@$self) + { s/$pattern/PQR/g } + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 qw( XYZ KLM) ; +use $module2 qw( ABC NMO) ; +EOM + +print "some letters ABCXYZ KLM NMO\n" ; +$y = "ABCDEFXYZKLMNMO" ; +print <<EOF ; +Alphabetti Spagetti ($y) +EOF + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(13, ($? >>8) == 0) ; +ok(14, $a eq <<EOM) ; +some letters PQRPQR PQR PQR +Alphabetti Spagetti (PQRDEFPQRPQRPQR) +EOM + +# multi line test +################# + + +writeFile("${module2}.pm", <<EOM, <<'EOM') ; +package ${module2} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add(bless []) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + # read first line + if (($status = filter_read()) > 0) { + chop ; + s/\r$//; + # and now the second line (it will append) + $status = filter_read() ; + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <<EOM, <<'EOM') ; + +use $module2 ; +EOM +print "don't cut me +in half\n" ; +print +<<EOF ; +appen +ded +EO +F + +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(15, ($? >>8) == 0) ; +ok(16, $a eq <<EOM) ; +don't cut me in half +appended +EOM + +# Block test +############# + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add (bless [@strings] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($pattern) ; + + filter_read(20) ; +} + +1 ; +EOM + +$string = <<'EOM' ; +print "hello mum\n" ; +$x = 'me ' x 3 ; +print "Who wants it?\n$x\n" ; +EOM + + +writeFile($filename, <<EOM, $string ) ; +use $block ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(17, ($? >>8) == 0) ; +ok(18, $a eq <<EOM) ; +hello mum +Who wants it? +me me me +EOM + +# use in the filter +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM +use Cwd ; + +sub import +{ + my ($type) = shift ; + my (@strings) = @_ ; + + + filter_add(bless [@strings] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($here) = quotemeta getcwd ; + + if (($status = filter_read()) > 0) { + s/DIR/$here/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "We are in DIR\n" ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(19, ($? >>8) == 0) ; +ok(20, $a eq <<EOM) ; +We are in $here +EOM + + +# filter_del +############# + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + my ($count) = @_ ; + + + filter_add(bless \$count ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + s/HERE/THERE/g + if ($status = filter_read()) > 0 ; + + -- $$self ; + filter_del() if $$self <= 0 ; + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block (3) ; +EOM +print " +HERE I am +I am HERE +HERE today gone tomorrow\n" ; +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(21, ($? >>8) == 0) ; +ok(22, $a eq <<EOM) ; + +THERE I am +I am THERE +HERE today gone tomorrow +EOM + + +# filter_read_exact +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read_exact(9)) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filenamebin, <<EOM, <<'EOM') ; +use $block ; +EOM +print " +HERE I am +I'm HERE +HERE today gone tomorrow\n" ; +EOM + +$a = `$Perl "-I." $Inc $filenamebin 2>&1` ; +ok(23, ($? >>8) == 0) ; +ok(24, $a eq <<EOM) ; + +HERE I am +I'm THERE +THERE today gone tomorrow +EOM + +{ + +# Check __DATA__ +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "HERE HERE\n"; +@a = <DATA>; +print @a; +__DATA__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(25, ($? >>8) == 0) ; +ok(26, $a eq <<EOM) ; +THERE THERE +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +} + +{ + +# Check __END__ +#################### + +writeFile("${block}.pm", <<EOM, <<'EOM') ; +package ${block} ; +use Filter::Util::Call ; + +EOM + +sub import +{ + my ($type) = shift ; + + filter_add(bless [] ) +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <<EOM, <<'EOM') ; +use $block ; +EOM +print "HERE HERE\n"; +@a = <DATA>; +print @a; +__END__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(27, ($? >>8) == 0) ; +ok(28, $a eq <<EOM) ; +THERE THERE +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +} + +END { + 1 while unlink $filename ; + 1 while unlink $filenamebin ; + 1 while unlink "${module}.pm" ; + 1 while unlink "${module2}.pm" ; + 1 while unlink "${module3}.pm" ; + 1 while unlink "${module4}.pm" ; + 1 while unlink "${module5}.pm" ; + 1 while unlink $nested ; + 1 while unlink "${block}.pm" ; +} + + diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t index 9503ea7585..2209baa025 100755 --- a/t/lib/ftmp-mktemp.t +++ b/t/lib/ftmp-mktemp.t @@ -15,6 +15,7 @@ use strict; use File::Spec; use File::Path; use File::Temp qw/ :mktemp unlink0 /; +use FileHandle; ok(1); diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t index 2e455861e9..bc3845c22b 100755 --- a/t/lib/ftmp-posix.t +++ b/t/lib/ftmp-posix.t @@ -11,6 +11,8 @@ BEGIN { use strict; use File::Temp qw/ :POSIX unlink0 /; +use FileHandle; + ok(1); # TMPNAM - scalar diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t index 48a52b3c92..ed59765a75 100755 --- a/t/lib/ftmp-tempfile.t +++ b/t/lib/ftmp-tempfile.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Test; import Test; - plan(tests => 16); + plan(tests => 20); } use strict; @@ -51,6 +51,10 @@ my ($fh, $tempfile) = tempfile( ); ok( (-f $tempfile) ); +# Should still be around after closing +ok( close( $fh ) ); +ok( (-f $tempfile) ); +# Check again at exit push(@files, $tempfile); # TEMPDIR test @@ -113,5 +117,29 @@ ok( -f $tempfile ); ok( close( $fh ) ); push( @still_there, $tempfile); # check at END +# Would like to create a temp file and just retrieve the handle +# but the test is problematic since: +# - We dont know the filename so we cant check that it is tidied +# correctly +# - The unlink0 required on unix for tempfile creation will fail +# on NFS +# Try to do what we can. +# Tempfile croaks on error so we need an eval +$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; + +if ($fh) { + + # print something to it to make sure something is there + ok( print $fh "Test\n" ); + + # Close it - can not check it is gone since we dont know the name + ok( close($fh) ); + +} else { + skip "Skip Failed probably due to NFS", 1; + skip "Skip Failed probably due to NFS", 1; +} + # Now END block will execute to test the removal of directories +print "# End of tests. Execute END blocks\n"; diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index 54f59946b7..af83fdda81 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -13,7 +13,7 @@ BEGIN { use GDBM_File; -print "1..66\n"; +print "1..68\n"; unlink <Op.dbmx*>; @@ -178,6 +178,7 @@ EOM close FILE ; BEGIN { push @INC, '.'; } + unlink <dbhash.tmp*> ; eval 'use SubDB ; '; main::ok(13, $@ eq "") ; @@ -392,3 +393,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/t/lib/io_sock.t b/t/lib/io_sock.t index 5a8e16c313..38292a7a59 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -30,7 +30,7 @@ BEGIN { } $| = 1; -print "1..14\n"; +print "1..20\n"; use IO::Socket; @@ -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,10 +150,14 @@ 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"); + } else { + print "not ok 11\n"; } $sock = undef; sleep(1); @@ -166,7 +169,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 +185,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 @@ -195,3 +203,131 @@ print "ok 13\n"; $server->blocking(0); print "not " if $server->blocking; print "ok 14\n"; + +### TEST 15 +### Set up some data to be transfered between the server and +### the client. We'll use own source code ... +# +local @data; +if( !open( SRC, "< $0")) { + print "not ok 15 - $!"; +} else { + @data = <SRC>; + close( SRC); +} +print "ok 15\n"; + +### TEST 16 +### Start the server +# +my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || + print "not "; +print "ok 16\n"; +die if( !defined( $listen)); +my $serverport = $listen->sockport; + +my $server_pid = fork(); +if( $server_pid) { + + ### TEST 17 Client/Server establishment + # + print "ok 17\n"; + + ### TEST 18 + ### Get data from the server using a single stream + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( <$sock>) { + push( @array, $_); + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 18\n"; + + ### TEST 19 + ### Get data from the server using a stream, which is + ### interrupted by eof calls. + ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof + ### did an getc followed by an ungetc in order to check for the streams + ### end. getc(3) got replaced by the SOCKS funktion, which ended up in + ### a recv(2) call on the socket, while ungetc(3) put back a character + ### to an IO buffer, which never again was read. + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("send\n"); + + my @array = (); + while( !eof( $sock ) ){ + while( <$sock>) { + push( @array, $_); + last; + } + } + + $sock->print("done\n"); + $sock->close; + + print "not " if( @array != @data); + } else { + print "not "; + } + print "ok 19\n"; + + ### TEST 20 + ### Stop the server + # + $sock = IO::Socket::INET->new("localhost:$serverport") + || IO::Socket::INET->new("127.0.0.1:$serverport"); + + if ($sock) { + $sock->print("done\n"); + $sock->close; + + print "not " if( 1 != kill 0, $server_pid); + } else { + print "not "; + } + print "ok 20\n"; + +} elsif( defined( $server_pid)) { + + ### Child + # + SERVER_LOOP: while (1) { + last SERVER_LOOP unless $sock = $listen->accept; + while (<$sock>) { + last SERVER_LOOP if /^quit/; + last if /^done/; + if( /^send/) { + print $sock @data; + last; + } + print; + } + $sock = undef; + } + $listen->close; + +} else { + + ### Fork failed + # + print "not ok 17\n"; + die; +} + diff --git a/t/lib/io_tell.t b/t/lib/io_tell.t index 3aa4b031e1..65c63bdfc9 100755 --- a/t/lib/io_tell.t +++ b/t/lib/io_tell.t @@ -27,7 +27,7 @@ print "1..13\n"; use IO::File; $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos'); +binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos'); if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$tst>; diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 9df62cfbaf..d63a5dcf7b 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -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/t/lib/io_xs.t b/t/lib/io_xs.t index 9305c31986..2449fc45c1 100755 --- a/t/lib/io_xs.t +++ b/t/lib/io_xs.t @@ -40,3 +40,4 @@ print scalar <$x>; $! = 0; $x->setpos(undef); print $! ? "ok 4 # $!\n" : "not ok 4\n"; + diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index 4937a8ce31..a8344444c8 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -16,7 +16,7 @@ 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*>; @@ -391,3 +391,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/t/lib/net-hostent.t b/t/lib/net-hostent.t new file mode 100644 index 0000000000..abc5b9292f --- /dev/null +++ b/t/lib/net-hostent.t @@ -0,0 +1,72 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0 # Test uses Socket, Socket not built\n"; + exit 0; + } +} + +BEGIN { $| = 1; print "1..7\n"; } + +END {print "not ok 1\n" unless $loaded;} + +use Net::hostent; + +$loaded = 1; +print "ok 1\n"; + +# test basic resolution of localhost <-> 127.0.0.1 +use Socket; + +my $h = gethost('localhost'); +print +(defined $h ? '' : 'not ') . "ok 2\n"; +my $i = gethostbyaddr(inet_aton("127.0.0.1")); +print +(!defined $i ? 'not ' : '') . "ok 3\n"; + +print "not " if inet_ntoa($h->addr) ne "127.0.0.1"; +print "ok 4\n"; + +print "not " if inet_ntoa($i->addr) ne "127.0.0.1"; +print "ok 5\n"; + +# need to skip the name comparisons on Win32 because windows will +# return the name of the machine instead of "localhost" when resolving +# 127.0.0.1 or even "localhost" + +# VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others +# OS/390 returns localhost.YADDA.YADDA + +if ($^O eq 'MSWin32' or $^O eq 'cygwin') { + print "ok $_ # skipped on win32\n" for (6,7); +} else { + my $in_alias; + unless ($h->name =~ /^localhost(?:\..+)?$/i) { + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + $in_alias = 1; + last; + } + } + print "not " unless $in_alias; + } # Else we found it as the hostname + print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; + + if ($in_alias) { + # If we found it in the aliases before, expect to find it there again. + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + undef $in_alias; # This time, clear the flag if we see "localhost" + last; + } + } + print "not " if $in_alias; + } else { + print "not " unless $i->name =~ /^localhost(?:\..+)?$/i; + } + print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; +} diff --git a/t/lib/odbm.t b/t/lib/odbm.t index ccd3e60319..f2c1bb6d32 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -16,7 +16,7 @@ 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*>; @@ -394,6 +394,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/t/lib/peek.t b/t/lib/peek.t index a90574f744..288d3bdf6d 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -88,10 +88,10 @@ do_test( 5, do_test( 6, $c + $d, -'SV = NV\\($ADDR\\) at $ADDR +'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADTMP,NOK,pNOK\\) - NV = 456'); + FLAGS = \\(PADTMP,IOK,pIOK\\) + IV = 456'); ($d = "789") += 0.1; @@ -110,8 +110,8 @@ do_test( 8, 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) - UV = 43981'); + FLAGS = \\(.*IOK,READONLY,pIOK\\) + IV = 43981'); do_test( 9, undef, @@ -154,12 +154,10 @@ do_test(11, FLAGS = \\(IOK,pIOK\\) IV = 123 Elt No. 1 - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(12, {$b=>$c}, @@ -180,12 +178,10 @@ do_test(12, RITER = -1 EITER = 0x0 Elt "123" HASH = $ADDR - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(13, sub(){@_}, diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index b6a1a69de0..d60447e960 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -15,7 +15,7 @@ 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.*>; @@ -396,3 +396,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/t/lib/st-lock.t b/t/lib/st-lock.t index 28fe66490e..77d73bbb79 100644 --- a/t/lib/st-lock.t +++ b/t/lib/st-lock.t @@ -1,10 +1,19 @@ #!./perl -# $Id: lock.t,v 1.0.1.1 2000/09/28 21:44:06 ram Exp $ +# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $ # # @COPYRIGHT@ # # $Log: lock.t,v $ +# Revision 1.0.1.4 2001/01/03 09:41:00 ram +# patch7: use new CAN_FLOCK routine to determine whether to run tests +# +# Revision 1.0.1.3 2000/10/26 17:11:27 ram +# patch5: just check $^O, there's no need for the whole Config +# +# Revision 1.0.1.2 2000/10/23 18:03:07 ram +# patch4: protected calls to flock() for dos platform +# # Revision 1.0.1.1 2000/09/28 21:44:06 ram # patch2: created. # @@ -19,10 +28,7 @@ sub BEGIN { print "1..0 # Skip: Storable was not built\n"; exit 0; } - if (!$Config{'d_flock'} && !$Config{'d_fcntl'} && !$Config{'d_lockf'}) { - print "1..0 # Skip: no flock or flock emulation on this platform\n"; - exit 0; - } + require 'lib/st-dump.pl'; } @@ -30,6 +36,11 @@ sub ok; use Storable qw(lock_store lock_retrieve); +unless (&Storable::CAN_FLOCK) { + print "1..0 # Skip: fcntl/flock emulation broken on this platform\n"; + exit 0; +} + print "1..5\n"; @a = ('first', undef, 3, -4, -3.14159, 456, 4.5); diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t index dcf6d1a029..b42974748e 100644 --- a/t/lib/st-recurse.t +++ b/t/lib/st-recurse.t @@ -1,6 +1,6 @@ #!./perl -# $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 ram Exp $ +# $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,10 @@ # in the README file that comes with the distribution. # # $Log: recurse.t,v $ +# Revision 1.0.1.2 2000/11/05 17:22:05 ram +# patch6: stress hook a little more with refs to lexicals +# +# $Log: recurse.t,v $ # Revision 1.0.1.1 2000/09/17 16:48:05 ram # patch1: added test case for store hook bug # @@ -97,15 +101,19 @@ sub make { sub STORABLE_freeze { my $self = shift; - my $t = dclone($self->{sync}); - return ("", [$t, $self->{ext}], $self, $self->{ext}); + my %copy = %$self; + my $r = \%copy; + my $t = dclone($r->{sync}); + return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); } sub STORABLE_thaw { my $self = shift; - my ($cloning, $undef, $a, $obj, $ext) = @_; + my ($cloning, $undef, $a, $r, $obj, $ext) = @_; die "STORABLE_thaw #1" unless $obj eq $self; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; + die "STORABLE_thaw #3" unless ref $r eq 'HASH'; + die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; $self->{ok} = $self; ($self->{sync}, $self->{ext}) = @$a; } diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t index 96625f2c88..2bdb69d7e0 100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@ -14,6 +14,11 @@ BEGIN { 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 # Skip: 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 # Skip: 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(); } @@ -120,9 +132,8 @@ sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { $sysseek = 'undef' unless defined $sysseek; - print "1..0 # Skip: seeking past 2GB failed: ", - $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)", "\n"; - explain(); + explain("seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); bye(); } @@ -135,11 +146,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0 # Skip: writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0 # Skip: filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -148,8 +160,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0 # Skip: not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -158,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"; @@ -176,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; @@ -209,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; @@ -220,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/t/lib/syslog.t b/t/lib/syslog.t index 7ad4204ee0..04adb6bed9 100755 --- a/t/lib/syslog.t +++ b/t/lib/syslog.t @@ -8,21 +8,56 @@ BEGIN { print "1..0 # Skip: Sys::Syslog was not built\n"; exit 0; } + + require Socket; + + # This code inspired by Sys::Syslog::connect(): + require Sys::Hostname; + my ($host_uniq) = Sys::Hostname::hostname(); + my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; + + if (! defined Socket::inet_aton($host)) { + print "1..0 # Skip: Can't lookup $host\n"; + exit 0; + } } use Sys::Syslog qw(:DEFAULT setlogsock); +# Test this to 1 if your syslog accepts udp connections. +# Most don't (or at least shouldn't) +my $Test_Syslog_INET = 0; + print "1..6\n"; if (Sys::Syslog::_PATH_LOG()) { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; + if (-e Sys::Syslog::_PATH_LOG()) { + print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; + print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; + print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; + } + else { + for (1..3) { + print + "ok $_ # skipping, file ", + Sys::Syslog::_PATH_LOG(), + " does not exist\n"; + } + } } else { for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" } } -print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n"; -print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n"; -print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n"; +if( $Test_Syslog_INET ) { + print defined(eval { setlogsock('inet') }) ? "ok 4\n" + : "not ok 4\n"; + print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" + : "not ok 5\n"; + print defined(eval { syslog('info', 'test') }) ? "ok 6\n" + : "not ok 6\n"; +} +else { + print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n" + foreach (4..6); +} diff --git a/t/lib/thr5005.t b/t/lib/thr5005.t index 680e1af3e7..bc6aed7182 100755 --- a/t/lib/thr5005.t +++ b/t/lib/thr5005.t @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..22\n"; +print "1..74\n"; use Thread 'yield'; print "ok 1\n"; @@ -129,3 +129,79 @@ $thr1->join; $thr2->join; $thr3->join; print "ok 22\n"; + +{ + my $THRf_STATE_MASK = 7; + my $THRf_R_JOINABLE = 0; + my $THRf_R_JOINED = 1; + my $THRf_R_DETACHED = 2; + my $THRf_ZOMBIE = 3; + my $THRf_DEAD = 4; + my $THRf_DID_DIE = 8; + sub _test { + my($test, $t, $state, $die) = @_; + my $flags = $t->flags; + if (($flags & $THRf_STATE_MASK) == $state + && !($flags & $THRf_DID_DIE) == !$die) { + print "ok $test\n"; + } else { + print <<BAD; +not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]} +BAD + } + } + + my @t; + push @t, ( + Thread->new(sub { sleep 4; die "thread die\n" }), + Thread->new(sub { die "thread die\n" }), + Thread->new(sub { sleep 4; 1 }), + Thread->new(sub { 1 }), + ) for 1, 2; + $_->detach for @t[grep $_ & 4, 0..$#t]; + + sleep 1; + my $test = 23; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE + : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; + _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; + } +# $test = 39; + for (grep $_ & 1, 0..$#t) { + next if $_ & 4; # can't join detached threads + $t[$_]->eval; + my $die = ($_ & 2) ? "" : "thread die\n"; + printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; + } +# $test = 41; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD + : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; + _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; + } +# $test = 57; + for (grep !($_ & 1), 0..$#t) { + next if $_ & 4; # can't join detached threads + $t[$_]->eval; + my $die = ($_ & 2) ? "" : "thread die\n"; + printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; + } + sleep 1; # make sure even the detached threads are done sleeping +# $test = 59; + for (0..7) { + my $t = $t[$_]; + my $flags = ($_ & 1) + ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD + : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD; + _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE); + printf "%sok %s\n", $t->done ? "" : "not ", $test++; + } +# $test = 75; +} diff --git a/t/lib/tie-refhash.t b/t/lib/tie-refhash.t new file mode 100644 index 0000000000..d80b2e10fc --- /dev/null +++ b/t/lib/tie-refhash.t @@ -0,0 +1,305 @@ +#!/usr/bin/perl -w +# +# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. +# +# The testing is in two parts: first, run lots of tests on both a tied +# hash and an ordinary un-tied hash, and check they give the same +# answer. Then there are tests for those cases where the tied hashes +# should behave differently to normal hashes, that is, when using +# references as keys. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +use strict; +use Tie::RefHash; +use Data::Dumper; +my $numtests = 34; +my $currtest = 1; +print "1..$numtests\n"; + +my $ref = []; my $ref1 = []; + +# Test standard hash functionality, by performing the same operations +# on a tied hash and on a normal hash, and checking that the results +# are the same. This does of course assume that Perl hashes are not +# buggy :-) +# +my @tests = standard_hash_tests(); + +my @ordinary_results = runtests(\@tests, undef); +foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { + my @tied_results = runtests(\@tests, $class); + my $all_ok = 1; + + die if @ordinary_results != @tied_results; + foreach my $i (0 .. $#ordinary_results) { + my ($or, $ow, $oe) = @{$ordinary_results[$i]}; + my ($tr, $tw, $te) = @{$tied_results[$i]}; + + my $ok = 1; + local $^W = 0; + $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); + $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); + $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); + + if (not $ok) { + print STDERR + "failed for $class: $tests[$i]\n", + "ordinary hash gave:\n", + defined $or ? "\tresult: $or\n" : "\tundef result\n", + defined $ow ? "\twarning: $ow\n" : "\tno warning\n", + defined $oe ? "\texception: $oe\n" : "\tno exception\n", + "tied $class hash gave:\n", + defined $tr ? "\tresult: $tr\n" : "\tundef result\n", + defined $tw ? "\twarning: $tw\n" : "\tno warning\n", + defined $te ? "\texception: $te\n" : "\tno exception\n", + "\n"; + $all_ok = 0; + } + } + test($all_ok); +} + +# Now test Tie::RefHash's special powers +my (%h, $h); +$h = eval { tie %h, 'Tie::RefHash' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); +$h{$ref} = 'cholet'; +test($h{$ref} eq 'cholet'); +test(exists $h{$ref}); +test((keys %h) == 1); +test(ref((keys %h)[0]) eq 'ARRAY'); +test((keys %h)[0] eq $ref); +test((values %h) == 1); +test((values %h)[0] eq 'cholet'); +my $count = 0; +while (my ($k, $v) = each %h) { + if ($count++ == 0) { + test(ref($k) eq 'ARRAY'); + test($k eq $ref); + } +} +test($count == 1); +delete $h{$ref}; +test(not defined $h{$ref}); +test(not exists($h{$ref})); +test((keys %h) == 0); +test((values %h) == 0); +undef $h; +untie %h; + +# And now Tie::RefHash::Nestable's differences from Tie::RefHash. +$h = eval { tie %h, 'Tie::RefHash::Nestable' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash::Nestable'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); +$h{$ref}->{$ref1} = 'bungo'; +test($h{$ref}->{$ref1} eq 'bungo'); + +# Test that the nested hash is also tied (for current implementation) +test(defined(tied(%{$h{$ref}})) + and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); + +test((keys %h) == 1); +test((keys %h)[0] eq $ref); +test((keys %{$h{$ref}}) == 1); +test((keys %{$h{$ref}})[0] eq $ref1); + + +die "expected to run $numtests tests, but ran ", $currtest - 1 + if $currtest - 1 != $numtests; + +@tests = (); +undef $ref; +undef $ref1; + +exit(); + + +# Print 'ok X' if true, 'not ok X' if false +# Uses global $currtest. +# +sub test { + my $t = shift; + print 'not ' if not $t; + print 'ok ', $currtest++, "\n"; +} + + +# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. +sub dumped { + my $s = shift; + my $d = Dumper($s); + $d =~ s/^\$VAR1 =\s*//; + $d =~ s/;$//; + chomp $d; + return $d; +} + +# Crudely dump a hash into a canonical string representation (because +# hash keys can appear in any order, Data::Dumper may give different +# strings for the same hash). +# +sub dumph { + my $h = shift; + my $r = ''; + foreach (sort keys %$h) { + $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; + } + return $r; +} + +# Run the tests and give results. +# +# Parameters: reference to list of tests to run +# name of class to use for tied hash, or undef if not tied +# +# Returns: list of [R, W, E] tuples, one for each test. +# R is the return value from running the test, W any warnings it gave, +# and E any exception raised with 'die'. E and W will be tidied up a +# little to remove irrelevant details like line numbers :-) +# +# Will also run a few of its own 'ok N' tests. +# +sub runtests { + my ($tests, $class) = @_; + my @r; + + my (%h, $h); + if (defined $class) { + $h = eval { tie %h, $class }; + warn $@ if $@; + test(not $@); + test(ref($h) eq $class); + test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); + } + + foreach (@$tests) { + my ($result, $warning, $exception); + local $SIG{__WARN__} = sub { $warning .= $_[0] }; + $result = scalar(eval $_); + if ($@) + { + die "$@:$_" unless defined $class; + $exception = $@; + } + + foreach ($warning, $exception) { + next if not defined; + s/ at .+ line \d+\.$//mg; + s/ at .+ line \d+, at .*//mg; + s/ at .+ line \d+, near .*//mg; + } + + my (@warnings, %seen); + foreach (split /\n/, $warning) { + push @warnings, $_ unless $seen{$_}++; + } + $warning = join("\n", @warnings); + + push @r, [ $result, $warning, $exception ]; + } + + return @r; +} + + +# Things that should work just the same for an ordinary hash and a +# Tie::RefHash. +# +# Each test is a code string to be eval'd, it should do something with +# %h and give a scalar return value. The global $ref and $ref1 may +# also be used. +# +# One thing we don't test is that the ordering from 'keys', 'values' +# and 'each' is the same. You can't reasonably expect that. +# +sub standard_hash_tests { + my @r; + + # Library of standard tests on keys, values and each + my $STD_TESTS = <<'END' + join $;, sort keys %h; + join $;, sort values %h; + { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } + { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) } +END + ; + + # Tests on the existence of the element 'foo' + my $FOO_TESTS = <<'END' + defined $h{foo}; + exists $h{foo}; + $h{foo}; +END + ; + + # Test storing and deleting 'foo' + push @r, split /\n/, <<"END" + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = undef; + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = 'hello'; + $STD_TESTS; + $FOO_TESTS; + delete \$h{foo}; + $STD_TESTS; + $FOO_TESTS; +END + ; + + # Test storing and removing under ordinary keys + my @things = ('boink', 0, 1, '', undef); + foreach my $key (map { dumped($_) } @things) { + foreach my $value ((map { dumped($_) } @things), '$ref') { + push @r, split /\n/, <<"END" + \$h{$key} = $value; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; + delete \$h{$key}; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; +END + ; + } + } + + # Test hash slices + my @slicetests; + @slicetests = split /\n/, <<'END' + @h{'b'} = (); + @h{'c'} = ('d'); + @h{'e'} = ('f', 'g'); + @h{'h', 'i'} = (); + @h{'j', 'k'} = ('l'); + @h{'m', 'n'} = ('o', 'p'); + @h{'q', 'r'} = ('s', 't', 'u'); +END + ; + my @aaa = @slicetests; + foreach (@slicetests) { + push @r, $_; + push @r, split(/\n/, $STD_TESTS); + } + + # Test CLEAR + push @r, '%h = ();', split(/\n/, $STD_TESTS); + + return @r; +} + diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t new file mode 100644 index 0000000000..d7ea6cc1dc --- /dev/null +++ b/t/lib/tie-splice.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +# bug id 20001020.002 +# -dlc 20001021 + +use Tie::Array; +tie @a,Tie::StdArray; +undef *Tie::StdArray::SPLICE; +require "op/splice.t" + +# Pre-fix, this failed tests 6-9 diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t new file mode 100644 index 0000000000..8256db7b58 --- /dev/null +++ b/t/lib/tie-substrhash.t @@ -0,0 +1,111 @@ +#!/usr/bin/perl -w +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +print "1..20\n"; + +use strict; + +require Tie::SubstrHash; + +my %a; + +tie %a, 'Tie::SubstrHash', 3, 3, 3; + +$a{abc} = 123; +$a{bcd} = 234; + +print "not " unless $a{abc} == 123; +print "ok 1\n"; + +print "not " unless keys %a == 2; +print "ok 2\n"; + +delete $a{abc}; + +print "not " unless $a{bcd} == 234; +print "ok 3\n"; + +print "not " unless (values %a)[0] == 234; +print "ok 4\n"; + +eval { $a{abcd} = 123 }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 5\n"; + +eval { $a{abc} = 1234 }; +print "not " unless $@ =~ /Value "1234" is not 3 characters long/; +print "ok 6\n"; + +eval { $a = $a{abcd}; $a++ }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 7\n"; + +@a{qw(abc cde)} = qw(123 345); + +print "not " unless $a{cde} == 345; +print "ok 8\n"; + +eval { $a{def} = 456 }; +print "not " unless $@ =~ /Table is full \(3 elements\)/; +print "ok 9\n"; + +%a = (); + +print "not " unless keys %a == 0; +print "ok 10\n"; + +# Tests 11..16 by Linc Madison. + +my $hashsize = 119; # arbitrary values from my data +my %test; +tie %test, "Tie::SubstrHash", 13, 86, $hashsize; + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; # fix to uniform 6-digit numbers + my $key2 = "abcdefg$key1"; + $test{$key2} = ("abcdefgh" x 10) . "$key1"; +} + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; + my $key2 = "abcdefg$key1"; + unless ($test{$key2}) { + print "not "; + last; + } +} +print "ok 11\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1) == 2; +print "ok 12\n"; + +print "not " unless Tie::SubstrHash::findgteprime(2) == 2; +print "ok 13\n"; + +print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; +print "ok 14\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13) == 13; +print "ok 15\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; +print "ok 16\n"; + +print "not " unless Tie::SubstrHash::findgteprime(114) == 127; +print "ok 17\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; +print "ok 18\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; +print "ok 19\n"; + +print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; +print "ok 20\n"; + diff --git a/t/op/64bitint.t b/t/op/64bitint.t index 88fbc55c67..c34d188c37 100644 --- a/t/op/64bitint.t +++ b/t/op/64bitint.t @@ -16,7 +16,7 @@ BEGIN { # 32+ bit integers don't cause noise no warnings qw(overflow portable); -print "1..55\n"; +print "1..58\n"; my $q = 12345678901; my $r = 23456789012; @@ -294,4 +294,36 @@ $q = 18446744073709551615; print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; print "ok 55\n"; +# Test that sv_2nv then sv_2iv is the same as sv_2iv direct +# fails if whatever Atol is defined as can't actually cope with >32 bits. +my $num = 4294967297; +my $string = "4294967297"; +{ + use integer; + $num += 0; + $string += 0; +} +if ($num eq $string) { + print "ok 56\n"; +} else { + print "not ok 56 # \"$num\" ne \"$string\"\n"; +} + +# Test that sv_2nv then sv_2uv is the same as sv_2uv direct +$num = 4294967297; +$string = "4294967297"; +$num &= 0; +$string &= 0; +if ($num eq $string) { + print "ok 57\n"; +} else { + print "not ok 57 # \"$num\" ne \"$string\"\n"; +} + +$q = "18446744073709551616e0"; +$q += 0; +print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615"; +print "ok 58\n"; + + # eof diff --git a/t/op/array.t b/t/op/array.t index 7cc84e3217..d48b5fbfa0 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..70\n"; +print "1..71\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -229,3 +229,8 @@ print "ok 69\n"; print "not " unless unshift(@ary,12) == 5; print "ok 70\n"; + +sub foo { "a" } +@foo=(foo())[0,0]; +$foo[1] eq "a" or print "not "; +print "ok 71\n"; diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t index 2d05b82289..aff433c464 100755 --- a/t/op/assignwarn.t +++ b/t/op/assignwarn.t @@ -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/t/op/attrs.t b/t/op/attrs.t index 2702004881..f9212e4c26 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -142,6 +142,10 @@ eval 'my A $x : plugh plover;'; mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; BEGIN {++$ntests} +eval 'package Cat; my Cat @socks;'; +mytest qr/^Can't declare class for non-scalar \@socks in "my"/; +BEGIN {++$ntests} + sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::foo { 1 } *Y::bar = \&X::foo; diff --git a/t/op/bop.t b/t/op/bop.t index fd080e6be8..622d1698fe 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..38\n"; +print "1..42\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -107,7 +107,7 @@ for (0x100...0xFFF) { if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); } if (@not36) { - print "# test 36 failed: @not36\n"; + print "# test 36 failed\n"; print "not "; } print "ok 36\n"; @@ -120,14 +120,46 @@ for my $i (0xEEE...0xF00) { 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); + ~$a ne chr($i).chr($j); } } if (@not37) { - print "# test 37 failed: @not37\n"; + 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"; diff --git a/t/op/chop.t b/t/op/chop.t index 6723ca3f1b..65d0669841 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..33\n"; # optimized @@ -89,3 +89,17 @@ $_ = "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"; diff --git a/t/op/cmp.t b/t/op/cmp.t index 4a7e68d448..ffd34c62dd 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -1,35 +1,185 @@ #!./perl -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# 2s complement assumption. Won't break test, just makes the internals of +# the SVs less interesting if were not on 2s complement system. +my $uv_max = ~0; +my $uv_maxm1 = ~0 ^ 1; +my $uv_big = $uv_max; +$uv_big = ($uv_big - 20000) | 1; +my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); +$iv_max = $uv_max; # Do copy, *then* divide +$iv_max /= 2; +$iv_min = $iv_max; +{ + use integer; + $iv0 = 2 - 2; + $iv1 = 3 - 2; + $ivm1 = 2 - 3; + $iv_max -= 1; + $iv_min += 0; + $iv_big = $iv_max - 3; + $iv_small = $iv_min + 2; +} +my $uv_bigi = $iv_big; +$uv_bigi |= 0x0; + +# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, + 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, + $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, + $iv_small); -$expect = ($#FOO+2) * ($#FOO+1); +$expect = 6 * ($#FOO+2) * ($#FOO+1); print "1..$expect\n"; my $ok = 0; for my $i (0..$#FOO) { for my $j ($i..$#FOO) { $ok++; - my $cmp = $FOO[$i] <=> $FOO[$j]; - if (!defined($cmp) || - $cmp == -1 && $FOO[$i] < $FOO[$j] || - $cmp == 0 && $FOO[$i] == $FOO[$j] || - $cmp == 1 && $FOO[$i] > $FOO[$j]) + # Comparison routines may convert these internally, which would change + # what is used to determine the comparison on later runs. Hence copy + my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, + $i11, $i12, $i13, $i14, $i15) = + ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); + my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, + $j11, $j12, $j13, $j14, $j15) = + ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); + my $cmp = $i1 <=> $j1; + if (!defined($cmp) ? !($i2 < $j2) + : ($cmp == -1 && $i2 < $j2 || + $cmp == 0 && !($i2 < $j2) || + $cmp == 1 && !($i2 < $j2))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i4 == $j4) + : ($cmp == -1 && !($i4 == $j4) || + $cmp == 0 && $i4 == $j4 || + $cmp == 1 && !($i4 == $j4))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, == disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i5 > $j5) + : ($cmp == -1 && !($i5 > $j5) || + $cmp == 0 && !($i5 > $j5) || + $cmp == 1 && ($i5 > $j5))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, > disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i6 >= $j6) + : ($cmp == -1 && !($i6 >= $j6) || + $cmp == 0 && $i6 >= $j6 || + $cmp == 1 && $i6 >= $j6)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, >= disagrees\n"; + } + $ok++; + # OK, so the docs are wrong it seems. NaN != NaN + if (!defined($cmp) ? ($i7 != $j7) + : ($cmp == -1 && $i7 != $j7 || + $cmp == 0 && !($i7 != $j7) || + $cmp == 1 && $i7 != $j7)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, != disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i8 <= $j8) + : ($cmp == -1 && $i8 <= $j8 || + $cmp == 0 && $i8 <= $j8 || + $cmp == 1 && !($i8 <= $j8))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n"; + } + $ok++; + $cmp = $i9 cmp $j9; + if ($cmp == -1 && $i10 lt $j10 || + $cmp == 0 && !($i10 lt $j10) || + $cmp == 1 && !($i10 lt $j10)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n"; + } + $ok++; + if ($cmp == -1 && !($i11 eq $j11) || + $cmp == 0 && ($i11 eq $j11) || + $cmp == 1 && !($i11 eq $j11)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, eq disagrees\n"; + } + $ok++; + if ($cmp == -1 && !($i12 gt $j12) || + $cmp == 0 && !($i12 gt $j12) || + $cmp == 1 && ($i12 gt $j12)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, gt disagrees\n"; + } + $ok++; + if ($cmp == -1 && $i13 le $j13 || + $cmp == 0 && ($i13 le $j13) || + $cmp == 1 && !($i13 le $j13)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, le disagrees\n"; + } + $ok++; + if ($cmp == -1 && ($i14 ne $j14) || + $cmp == 0 && !($i14 ne $j14) || + $cmp == 1 && ($i14 ne $j14)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n"; } $ok++; - $cmp = $FOO[$i] cmp $FOO[$j]; - if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || - $cmp == 0 && $FOO[$i] eq $FOO[$j] || - $cmp == 1 && $FOO[$i] gt $FOO[$j]) + if ($cmp == -1 && !($i15 ge $j15) || + $cmp == 0 && ($i15 ge $j15) || + $cmp == 1 && ($i15 ge $j15)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n"; } } } diff --git a/t/op/concat.t b/t/op/concat.t new file mode 100644 index 0000000000..76074e0f28 --- /dev/null +++ b/t/op/concat.t @@ -0,0 +1,100 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +($a, $b, $c) = qw(foo bar); + +print "not " unless "$a" eq "foo"; +print "ok 1\n"; + +print "not " unless "$a$b" eq "foobar"; +print "ok 2\n"; + +print "not " unless "$c$a$c" eq "foo"; +print "ok 3\n"; + +# Okay, so that wasn't very challenging. Let's go Unicode. + +my $test = 4; + +{ + # bug id 20000819.004 + + $_ = $dx = "\x{10f2}"; + s/($dx)/$dx$1/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } + + $_ = $dx = "\x{10f2}"; + s/($dx)/$1$dx/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } + + $dx = "\x{10f2}"; + $_ = "\x{10f2}\x{10f2}"; + s/($dx)($dx)/$1$2/; + { + use bytes; + print "not " unless $_ eq "$dx$dx"; + print "ok $test\n"; + $test++; + } +} + +{ + # bug id 20000901.092 + # test that undef left and right of utf8 results in a valid string + + my $a; + $a .= "\x{1ff}"; + print "not " unless $a eq "\x{1ff}"; + print "ok $test\n"; + $test++; +} + +{ + # ID 20001020.006 + + "x" =~ /(.)/; # unset $2 + + # Without the fix this 5.7.0 would croak: + # Modification of a read-only value attempted at ... + "$2\x{1234}"; + + print "ok $test\n"; + $test++; + + # For symmetry with the above. + "\x{1234}$2"; + + print "ok $test\n"; + $test++; + + *pi = \undef; + # This bug existed earlier than the $2 bug, but is fixed with the same + # patch. Without the fix this 5.7.0 would also croak: + # Modification of a read-only value attempted at ... + "$pi\x{1234}"; + + print "ok $test\n"; + $test++; + + # For symmetry with the above. + "\x{1234}$pi"; + + print "ok $test\n"; + $test++; +} diff --git a/t/op/each.t b/t/op/each.t index 879c0d0fd3..35792ab9c3 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -1,6 +1,6 @@ #!./perl -print "1..19\n"; +print "1..24\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -131,3 +131,28 @@ if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } print "ok 19\n"; } +# Check for Unicode hash keys. +%u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); +$u{"\x{12345}"} = "bar"; +@u{"\x{123456}"} = "zap"; + +foreach (keys %u) { + unless (length() == 1) { + print "not "; + last; + } +} +print "ok 20\n"; + +$a = "\xe3\x81\x82"; $A = "\x{3042}"; +%b = ( $a => "non-utf8"); +%u = ( $A => "utf8"); + +print "not " if exists $b{$A}; +print "ok 21\n"; +print "not " if exists $u{$a}; +print "ok 22\n"; +print "#$b{$_}\n" for keys %b; # Used to core dump before change #8056. +print "ok 23\n"; +print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056. +print "ok 24\n"; diff --git a/t/op/fork.t b/t/op/fork.t index 93cf673228..fbcd0987fe 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -8,7 +8,9 @@ BEGIN { require Config; import Config; unless ($Config{'d_fork'} or ($^O eq 'MSWin32' and $Config{useithreads} - and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) + and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ +# and !defined $Config{'useperlio'} + )) { print "1..0 # Skip: no fork\n"; exit 0; @@ -184,6 +186,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"; diff --git a/t/op/goto_xs.t b/t/op/goto_xs.t index cf2cafd467..dc8e7d77aa 100755 --- a/t/op/goto_xs.t +++ b/t/op/goto_xs.t @@ -35,7 +35,7 @@ $VALID = 'LOCK_SH'; ### First, we check whether Fcntl::constant returns sane answers. # Fcntl::constant("LOCK_SH",0) should always succeed. -$value = Fcntl::constant($VALID,0); +$value = Fcntl::constant($VALID); print((!defined $value) ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" : "ok 1\n"); @@ -45,20 +45,20 @@ print((!defined $value) # test "goto &function_constant" sub goto_const { goto &Fcntl::constant; } -$ret = goto_const($VALID,0); +$ret = goto_const($VALID); print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" $FNAME1 = 'Fcntl::constant'; sub goto_name1 { goto &$FNAME1; } -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" again, with dirtier stack -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); -$ret = goto_name1($VALID,0); +$ret = goto_name1($VALID); print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); # test "goto &$function_name" from local package @@ -67,14 +67,14 @@ $FNAME2 = 'constant'; sub goto_name2 { goto &$FNAME2; } package main; -$ret = Fcntl::goto_name2($VALID,0); +$ret = Fcntl::goto_name2($VALID); print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); # test "goto &$function_ref" $FREF = \&Fcntl::constant; sub goto_ref { goto &$FREF; } -$ret = goto_ref($VALID,0); +$ret = goto_ref($VALID); print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); ### tests where the args are not on stack but in GvAV(defgv) (ie, @_) @@ -82,17 +82,17 @@ print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); # test "goto &function_constant" from a sub called without arglist sub call_goto_const { &goto_const; } -$ret = call_goto_const($VALID,0); +$ret = call_goto_const($VALID); print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); # test "goto &$function_package_and_name" from a sub called without arglist sub call_goto_name1 { &goto_name1; } -$ret = call_goto_name1($VALID,0); +$ret = call_goto_name1($VALID); print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); # test "goto &$function_ref" from a sub called without arglist sub call_goto_ref { &goto_ref; } -$ret = call_goto_ref($VALID,0); +$ret = call_goto_ref($VALID); print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); diff --git a/t/op/join.t b/t/op/join.t index b50878e735..0f849fda9c 100755 --- a/t/op/join.t +++ b/t/op/join.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\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";} @@ -44,3 +44,24 @@ if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} 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/t/op/length.t b/t/op/length.t new file mode 100644 index 0000000000..ceb005ecc4 --- /dev/null +++ b/t/op/length.t @@ -0,0 +1,85 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..13\n"; + +print "not " unless length("") == 0; +print "ok 1\n"; + +print "not " unless length("abc") == 3; +print "ok 2\n"; + +$_ = "foobar"; +print "not " unless length() == 6; +print "ok 3\n"; + +# Okay, so that wasn't very challenging. Let's go Unicode. + +{ + my $a = "\x{41}"; + + print "not " unless length($a) == 1; + print "ok 4\n"; + $test++; + + use bytes; + print "not " unless $a eq "\x41" && length($a) == 1; + print "ok 5\n"; + $test++; +} + +{ + my $a = "\x{80}"; + + print "not " unless length($a) == 1; + print "ok 6\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc2\x80" && length($a) == 2; + print "ok 7\n"; + $test++; +} + +{ + my $a = "\x{100}"; + + print "not " unless length($a) == 1; + print "ok 8\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc4\x80" && length($a) == 2; + print "ok 9\n"; + $test++; +} + +{ + my $a = "\x{100}\x{80}"; + + print "not " unless length($a) == 2; + print "ok 10\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4; + print "ok 11\n"; + $test++; +} + +{ + my $a = "\x{80}\x{100}"; + + print "not " unless length($a) == 2; + print "ok 12\n"; + $test++; + + use bytes; + print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; + print "ok 13\n"; + $test++; +} diff --git a/t/op/lfs.t b/t/op/lfs.t index feee8cc9b3..0a1c399840 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -13,6 +13,11 @@ BEGIN { } } +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 # Skip: 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 # Skip: 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(); } @@ -125,8 +137,7 @@ open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { my $err = $r ? 'signal '.($r & 0x7f) : $!; - print "1..0 # Skip: seeking past 2GB failed: $err\n"; - explain(); + explain("seeking past 2GB failed: $err"); bye(); } @@ -138,11 +149,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { - print "1..0 # Skip: writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0 # Skip: filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -151,8 +163,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0 # Skip: not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -161,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"; @@ -183,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; @@ -213,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"; @@ -224,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/t/op/local.t b/t/op/local.t index b478e01993..781afa5b35 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -1,6 +1,6 @@ #!./perl -print "1..69\n"; +print "1..71\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -235,3 +235,14 @@ while (/(o.+?),/gc) { untie $_; } +{ + # BUG 20001205.22 + my %x; + $x{a} = 1; + { local $x{b} = 1; } + print "not " if exists $x{b}; + print "ok 70\n"; + { local @x{c,d,e}; } + print "not " if exists $x{c}; + print "ok 71\n"; +} diff --git a/t/op/method.t b/t/op/method.t index be4df75fe2..1f5cbb64dc 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..53\n"; +print "1..54\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -185,3 +185,8 @@ test(do { eval 'E->foo()'; test(do { eval '$e = bless {}, "E"; $e->foo()'; $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +# This is actually testing parsing of indirect objects and undefined subs +# print foo("bar") where foo does not exist is not an indirect object. +# print foo "bar" where foo does not exist is an indirect object. +eval { sub AUTOLOAD { "ok ", shift, "\n"; } }; +print nonsuch(++$cnt); diff --git a/t/op/misc.t b/t/op/misc.t index f4424946a9..805a32bc9a 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -562,3 +562,58 @@ 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". +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +eval { + require POSIX; +}; +$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 +######## +die qr(x) +EXPECT +(?-xism:x) at - line 1. +######## +# 20001210.003 mjd@plover.com +format REMITOUT_TOP = +FOO +. + +format REMITOUT = +BAR +. + +# This loop causes a segv in 5.6.0 +for $lineno (1..61) { + write REMITOUT; +} + +print "It's OK!"; +EXPECT +It's OK! diff --git a/t/op/numconvert.t b/t/op/numconvert.t index f3c9867a91..3db280bbfd 100755 --- a/t/op/numconvert.t +++ b/t/op/numconvert.t @@ -85,8 +85,15 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, unshift @list, (reverse map -$_, @list), 0; # 15 elts @list = map "$_", @list; # Normalize -# print "@list\n"; +print "# @list\n"; +# need to special case ++ for max_uv, as ++ "magic" on a string gives +# another string, whereas ++ magic on a string used as a number gives +# a number. Not a problem when NV preserves UV, but if it doesn't then +# stringification of the latter gives something in e notation. + +my $max_uv_pp = "$max_uv"; $max_uv_pp++; +my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++; my @opnames = split //, "-+UINPuinp"; @@ -178,9 +185,18 @@ for my $num_chain (1..$max_chain) { } push @ans, $inpt; } - $nok++, - print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" - if $ans[0] ne $ans[1]; + if ($ans[0] ne $ans[1]) { + print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"; + # XXX ought to check that "+" was in the list of opnames + if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1)) + or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) { + # string ++ versus numeric ++. Tolerate this little + # bit of insanity + print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n" + } else { + $nok++, + } + } } print "not " if $nok; print "ok $test\n"; diff --git a/t/op/ord.t b/t/op/ord.t index 22ff3af4ed..f664078d00 100755 --- a/t/op/ord.t +++ b/t/op/ord.t @@ -1,11 +1,11 @@ #!./perl -print "1..5\n"; +print "1..8\n"; # compile time evaluation -# 65 ASCII -# 193 EBCDIC +# 'A' 65 ASCII +# 'A' 193 EBCDIC if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} print "not " unless ord(chr(500)) == 500; @@ -18,6 +18,17 @@ if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n"; if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";} +print "not " unless ord(chr(500)) == 500; +print "ok 5\n"; + $x = 500; print "not " unless ord(chr($x)) == $x; -print "ok 5\n"; +print "ok 6\n"; + +print "not " unless ord("\x{1234}") == 0x1234; +print "ok 7\n"; + +$x = "\x{1234}"; +print "not " unless ord($x) == 0x1234; +print "ok 8\n"; + diff --git a/t/op/pat.t b/t/op/pat.t index f0090865a1..17df867fd9 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,7 +4,7 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..223\n"; +print "1..231\n"; BEGIN { chdir 't' if -d 't'; @@ -496,7 +496,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 +504,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 +545,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 +570,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; @@ -1064,7 +1097,8 @@ my %space = ( spc => " ", cr => "\r", lf => "\n", ff => "\f", -# The vertical tabulator seems miraculously be 12 both in ASCII and EBCDIC. +# There's no \v but the vertical tabulator seems miraculously +# be 11 both in ASCII and EBCDIC. vt => chr(11), false => "space" ); @@ -1073,14 +1107,25 @@ 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\n"; +print "ok $test # @space0\n"; $test++; print "not " unless "@space1" eq "cr ff lf spc tab vt"; -print "ok $test\n"; +print "ok $test # @space1\n"; $test++; print "not " unless "@space2" eq "spc tab"; -print "ok $test\n"; +print "ok $test # @space2\n"; $test++; +# bugid 20001021.005 - this caused a SEGV +print "not " unless undef =~ /^([^\/]*)(.*)$/; +print "ok $test\n"; +$test++; + +# bugid 20000731.001 + +print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/; +print "ok $test\n"; +$test++; + diff --git a/t/op/pos.t b/t/op/pos.t index 46811b7bbc..f3bc23c84a 100755 --- a/t/op/pos.t +++ b/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/t/op/re_tests b/t/op/re_tests index c2753e592e..52666daea5 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -46,8 +46,8 @@ a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- 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/ at (eval 96) line 1, <TESTS> line 49. -a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 97) line 1, <TESTS> line 50. +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 - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 192) line 1, <TESTS> line 98. -(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 193) line 1, <TESTS> line 99. +*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 - Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 205) line 1, <TESTS> line 106. -(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 206) line 1, <TESTS> line 107. +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 - Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 215) line 1, <TESTS> line 112. +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 ) before HERE mark in regex m/) << HERE (/ at (eval 230) line 1, <TESTS> line 120. +)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ [^ab]* cde y $& cde abc n - - a* y $& @@ -219,8 +219,8 @@ a[-]?c ac y $& ac 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- '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/ at (eval 431) line 1, <TESTS> line 222. -'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 432) line 1, <TESTS> line 223. +'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 - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 455) line 1, <TESTS> line 235. -'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 456) line 1, <TESTS> line 236. +'*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 - Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 468) line 1, <TESTS> line 243. -'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 469) line 1, <TESTS> line 244. +'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 - Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 478) line 1, <TESTS> line 249. +'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 ) before HERE mark in regex m/) << HERE (/ at (eval 499) line 1, <TESTS> line 260. +')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -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 - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ at (eval 780) line 1, <TESTS> line 400. -a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ at (eval 781) line 1, <TESTS> line 401. +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/ at (eval 783) line 1, <TESTS> line 403. +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,7 +441,7 @@ x(~~)*(?:(?:F)?)? x~~ y - - ^(\(+)?blah(?(1)(\)))$ blah y ($2) () ^(\(+)?blah(?(1)(\)))$ blah) n - - ^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ at (eval 868) line 1, <TESTS> line 444. +(?(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 @@ -473,7 +473,7 @@ $(?<=^(a)) a y $1 a ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ at (eval 950) line 1, <TESTS> line 476. +[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 - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ @@ -775,3 +775,9 @@ tt+$ xxxtt y - - '^.{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 diff --git a/t/op/ref.t b/t/op/ref.t index a2baab8e3b..8ae90424eb 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..56\n"; +print "1..61\n"; # Test glob operations. @@ -279,14 +279,34 @@ print $$_,"\n"; print ${\$_} for @a; } +# This test is the reason for postponed destruction in sv_unref +$a = [1,2,3]; +$a = $a->[1]; +print "not " unless $a == 2; +print "ok 54\n"; + +sub x::DESTROY {print "ok ", 54 + shift->[0], "\n"} +{ my $a1 = bless [4],"x"; + my $a2 = bless [3],"x"; + { my $a3 = bless [2],"x"; + my $a4 = bless [1],"x"; + 567; + } +} + + # test global destruction +my $test = 59; +my $test1 = $test + 1; +my $test2 = $test + 2; + package FINALE; { - $ref3 = bless ["ok 56\n"]; # package destruction - my $ref2 = bless ["ok 55\n"]; # lexical destruction - local $ref1 = bless ["ok 54\n"]; # dynamic destruction + $ref3 = bless ["ok $test2\n"]; # package destruction + my $ref2 = bless ["ok $test1\n"]; # lexical destruction + local $ref1 = bless ["ok $test\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/regexp.t b/t/op/regexp.t index 23ae576c75..7fbfc97342 100755 --- a/t/op/regexp.t +++ b/t/op/regexp.t @@ -26,6 +26,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 @@ -56,7 +59,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 +73,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 +85,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/t/op/regmesg.t b/t/op/regmesg.t index f209239841..50a020bc4d 100644 --- a/t/op/regmesg.t +++ b/t/op/regmesg.t @@ -65,14 +65,12 @@ my @death = '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/', - 'my $m = chr(92); $m =~ $m', => 'Trailing \ in regex m/\/', + 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/', 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/', - '/\x{x}/' => 'Can\'t use \x{} without \'use utf8\' declaration before {#} mark in regex m/\x{x}{#}/', - '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/', '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/', @@ -101,15 +99,24 @@ my @death = my $total = (@death + @warning)/2; +# utf8 is a noop on EBCDIC platforms, it is not fatal +my $Is_EBCDIC = (ord('A') == 193); +if ($Is_EBCDIC) { + my @utf8_death = grep(/utf8/, @death); + $total = $total - $#utf8_death; +} + print "1..$total\n"; my $count = 0; while (@death) { - $count++; my $regex = shift @death; my $result = shift @death; + # skip the utf8 test on EBCDIC since they do not die + next if ($Is_EBCDIC && $regex =~ /utf8/); + $count++; $_ = "x"; eval $regex; diff --git a/t/op/reverse.t b/t/op/reverse.t new file mode 100644 index 0000000000..bb7b9b77fe --- /dev/null +++ b/t/op/reverse.t @@ -0,0 +1,33 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +print "not " unless reverse("abc") eq "cba"; +print "ok 1\n"; + +$_ = "foobar"; +print "not " unless reverse() eq "raboof"; +print "ok 2\n"; + +{ + my @a = ("foo", "bar"); + my @b = reverse @a; + + print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0]; + print "ok 3\n"; +} + +{ + # Unicode. + + my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; + my $b = scalar reverse($a); + my $c = scalar reverse($b); + print "not " unless $a eq $c; + print "ok 4\n"; +} diff --git a/t/op/sort.t b/t/op/sort.t index 9095871a29..c1dfb63ccb 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } use warnings; -print "1..57\n"; +print "1..58\n"; # XXX known to leak scalars { @@ -321,3 +321,10 @@ sub cxt_six { sort test_if_scalar 1,2 } print "# x = '@b'\n"; print !$def ? "ok 57\n" : "not ok 57\n"; } + +# Bug 19991001.003 +{ + sub routine { "one", "two" }; + @a = sort(routine(1)); + print "@a" eq "one two" ? "ok 58\n" : "not ok 58\n"; +} diff --git a/t/op/split.t b/t/op/split.t index 45df76a2bc..90c38e0770 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -1,6 +1,6 @@ #!./perl -print "1..28\n"; +print "1..30\n"; $FS = ':'; @@ -122,3 +122,13 @@ print "ok 27\n"; 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"; + +# unicode splittage +@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; +print "not " unless "@ary" eq "1 20 300 4000 50000 4000 300 20 1"; +print "ok 30\n"; diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 2f6cd276ad..4e80999bc3 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -229,8 +229,8 @@ __END__ >%.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< ->%.0f< >-0.6< >-1< >Known to fail with sfio< +>%.0f< >0.6< >1< >Known to fail with sfio and nonstop-ux< +>%.0f< >-0.6< >-1< >Known to fail with sfio and nonstop-ux< >%.0f< >1< >1< >%#.0f< >1< >1.< >%g< >12345.6789< >12345.7< @@ -308,3 +308,16 @@ __END__ >%0*x< >[-10, ,2**32-1]< >ffffffff < >%y< >''< >%y INVALID< >%z< >''< >%z INVALID< +>%2$d %1$d< >[12, 34]< >34 12< +>%*2$d< >[12, 3]< > 12< +>%2$d %d< >[12, 34]< >34 12< +>%2$d %d %d< >[12, 34]< >34 12 34< +>%3$d %d %d< >[12, 34, 56]< >56 12 34< +>%2$*3$d %d< >[12, 34, 3]< > 34 12< +>%*3$2$d %d< >[12, 34, 3]< > 34 12< +>%2$d< >12< >0< +>%0$d< >12< >%0$d INVALID< +>%1$$d< >12< >%1$$d INVALID< +>%1$1$d< >12< >%1$1$d INVALID< +>%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID< +>%*2*2$d< >[12, 3]< >%*2*2$d INVALID< diff --git a/t/op/taint.t b/t/op/taint.t index 7cc4447a0b..1e3d3964c2 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -99,7 +99,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 @@ -681,3 +681,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/t/op/tie.t b/t/op/tie.t index afcc4a1635..4413ed2100 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -162,19 +162,28 @@ $C = $B = tied %H ; untie %H; EXPECT ######## - -# verify no leak when underlying object is selfsame tied variable -my ($a, $b); +# Forbidden aggregate self-ties +my ($a, $b) = (0, 0); sub Self::TIEHASH { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 0; } +sub Self::DESTROY { $b = $_[0] + 1; } +{ + my %c = 42; + tie %c, 'Self', \%c; +} +EXPECT +Self-ties of arrays and hashes are not supported +######## +# Allowed scalar self-ties +my ($a, $b) = (0, 0); +sub Self::TIESCALAR { bless $_[1], $_[0] } +sub Self::DESTROY { $b = $_[0] + 1; } { - my %b5; - $a = \%b5 + 0; - tie %b5, 'Self', \%b5; + my $c = 42; + $a = $c + 0; + tie $c, 'Self', \$c; } -die unless $a == $b; +die unless $a == 0 && $b == 43; EXPECT -Self-ties are not supported ######## # Interaction of tie and vec diff --git a/t/op/utf8decode.t b/t/op/utf8decode.t new file mode 100644 index 0000000000..4d05a6b8d3 --- /dev/null +++ b/t/op/utf8decode.t @@ -0,0 +1,183 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +no utf8; + +print "1..78\n"; + +my $test = 1; + +# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester, +# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt, +# version dated 2000-09-02. + +# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff +# because e.g. many patch programs have issues with binary data. + +my @MK = split(/\n/, <<__EOMK__); +1 Correct UTF-8 +1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" - 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5 +2 Boundary conditions +2.1 First possible sequence of certain length +2.1.1 y "\x00" 0 1 00 1 +2.1.2 y "\xc2\x80" 80 2 c2:80 1 +2.1.3 y "\xe0\xa0\x80" 800 3 e0:a0:80 1 +2.1.4 y "\xf0\x90\x80\x80" 10000 4 f0:90:80:80 1 +2.1.5 y "\xf8\x88\x80\x80\x80" 200000 5 f8:88:80:80:80 1 +2.1.6 y "\xfc\x84\x80\x80\x80\x80" 4000000 6 fc:84:80:80:80:80 1 +2.2 Last possible sequence of certain length +2.2.1 y "\x7f" 7f 1 7f 1 +2.2.2 y "\xdf\xbf" 7ff 2 df:bf 1 +# The ffff is illegal unless UTF8_ALLOW_FFFF +2.2.3 n "\xef\xbf\xbf" ffff 3 ef:bf:bf 1 character 0xffff +2.2.4 y "\xf7\xbf\xbf\xbf" 1fffff 4 f7:bf:bf:bf 1 +2.2.5 y "\xfb\xbf\xbf\xbf\xbf" 3ffffff 5 fb:bf:bf:bf:bf 1 +2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf" 7fffffff 6 fd:bf:bf:bf:bf:bf 1 +2.3 Other boundary conditions +2.3.1 y "\xed\x9f\xbf" d7ff 3 ed:9f:bf 1 +2.3.2 y "\xee\x80\x80" e000 3 ee:80:80 1 +2.3.3 y "\xef\xbf\xbd" fffd 3 ef:bf:bd 1 +2.3.4 y "\xf4\x8f\xbf\xbf" 10ffff 4 f4:8f:bf:bf 1 +2.3.5 y "\xf4\x90\x80\x80" 110000 4 f4:90:80:80 1 +3 Malformed sequences +3.1 Unexpected continuation bytes +3.1.1 n "\x80" - 1 80 - unexpected continuation byte 0x80 +3.1.2 n "\xbf" - 1 bf - unexpected continuation byte 0xbf +3.1.3 n "\x80\xbf" - 2 80:bf - unexpected continuation byte 0x80 +3.1.4 n "\x80\xbf\x80" - 3 80:bf:80 - unexpected continuation byte 0x80 +3.1.5 n "\x80\xbf\x80\xbf" - 4 80:bf:80:bf - unexpected continuation byte 0x80 +3.1.6 n "\x80\xbf\x80\xbf\x80" - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80 +3.1.7 n "\x80\xbf\x80\xbf\x80\xbf" - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80 +3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80 +3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf" - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80 +3.2 Lonely start characters +3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf " - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20 after start byte 0xc0 +3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef " - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20 after start byte 0xe0 +3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 " - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20 after start byte 0xf0 +3.2.4 n "\xf8 \xf9 \xfa \xfb " - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20 after start byte 0xf8 +3.2.5 n "\xfc \xfd " - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20 after start byte 0xfc +3.3 Sequences with last continuation byte missing +3.3.1 n "\xc0" - 1 c0 - 1 byte, need 2 +3.3.2 n "\xe0\x80" - 2 e0:80 - 2 bytes, need 3 +3.3.3 n "\xf0\x80\x80" - 3 f0:80:80 - 3 bytes, need 4 +3.3.4 n "\xf8\x80\x80\x80" - 4 f8:80:80:80 - 4 bytes, need 5 +3.3.5 n "\xfc\x80\x80\x80\x80" - 5 fc:80:80:80:80 - 5 bytes, need 6 +3.3.6 n "\xdf" - 1 df - 1 byte, need 2 +3.3.7 n "\xef\xbf" - 2 ef:bf - 2 bytes, need 3 +3.3.8 n "\xf7\xbf\xbf" - 3 f7:bf:bf - 3 bytes, need 4 +3.3.9 n "\xfb\xbf\xbf\xbf" - 4 fb:bf:bf:bf - 4 bytes, need 5 +3.3.10 n "\xfd\xbf\xbf\xbf\xbf" - 5 fd:bf:bf:bf:bf - 5 bytes, need 6 +3.4 Concatenation of incomplete sequences +3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf" - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0 after start byte 0xc0 +3.5 Impossible bytes +3.5.1 n "\xfe" - 1 fe - byte 0xfe +3.5.2 n "\xff" - 1 ff - byte 0xff +3.5.3 n "\xfe\xfe\xff\xff" - 4 fe:fe:ff:ff - byte 0xfe +4 Overlong sequences +4.1 Examples of an overlong ASCII character +4.1.1 n "\xc0\xaf" - 2 c0:af - 2 bytes, need 1 +4.1.2 n "\xe0\x80\xaf" - 3 e0:80:af - 3 bytes, need 1 +4.1.3 n "\xf0\x80\x80\xaf" - 4 f0:80:80:af - 4 bytes, need 1 +4.1.4 n "\xf8\x80\x80\x80\xaf" - 5 f8:80:80:80:af - 5 bytes, need 1 +4.1.5 n "\xfc\x80\x80\x80\x80\xaf" - 6 fc:80:80:80:80:af - 6 bytes, need 1 +4.2 Maximum overlong sequences +4.2.1 n "\xc1\xbf" - 2 c1:bf - 2 bytes, need 1 +4.2.2 n "\xe0\x9f\xbf" - 3 e0:9f:bf - 3 bytes, need 2 +4.2.3 n "\xf0\x8f\xbf\xbf" - 4 f0:8f:bf:bf - 4 bytes, need 3 +4.2.4 n "\xf8\x87\xbf\xbf\xbf" - 5 f8:87:bf:bf:bf - 5 bytes, need 4 +4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf" - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5 +4.3 Overlong representation of the NUL character +4.3.1 n "\xc0\x80" - 2 c0:80 - 2 bytes, need 1 +4.3.2 n "\xe0\x80\x80" - 3 e0:80:80 - 3 bytes, need 1 +4.3.3 n "\xf0\x80\x80\x80" - 4 f0:80:80:80 - 4 bytes, need 1 +4.3.4 n "\xf8\x80\x80\x80\x80" - 5 f8:80:80:80:80 - 5 bytes, need 1 +4.3.5 n "\xfc\x80\x80\x80\x80\x80" - 6 fc:80:80:80:80:80 - 6 bytes, need 1 +5 Illegal code positions +5.1 Single UTF-16 surrogates +5.1.1 n "\xed\xa0\x80" - 3 ed:a0:80 - UTF-16 surrogate 0xd800 +5.1.2 n "\xed\xad\xbf" - 3 ed:ad:bf - UTF-16 surrogate 0xdb7f +5.1.3 n "\xed\xae\x80" - 3 ed:ae:80 - UTF-16 surrogate 0xdb80 +5.1.4 n "\xed\xaf\xbf" - 3 ed:af:bf - UTF-16 surrogate 0xdbff +5.1.5 n "\xed\xb0\x80" - 3 ed:b0:80 - UTF-16 surrogate 0xdc00 +5.1.6 n "\xed\xbe\x80" - 3 ed:be:80 - UTF-16 surrogate 0xdf80 +5.1.7 n "\xed\xbf\xbf" - 3 ed:bf:bf - UTF-16 surrogate 0xdfff +5.2 Paired UTF-16 surrogates +5.2.1 n "\xed\xa0\x80\xed\xb0\x80" - 6 ed:a0:80:ed:b0:80 - UTF-16 surrogate 0xd800 +5.2.2 n "\xed\xa0\x80\xed\xbf\xbf" - 6 ed:a0:80:ed:bf:bf - UTF-16 surrogate 0xd800 +5.2.3 n "\xed\xad\xbf\xed\xb0\x80" - 6 ed:ad:bf:ed:b0:80 - UTF-16 surrogate 0xdb7f +5.2.4 n "\xed\xad\xbf\xed\xbf\xbf" - 6 ed:ad:bf:ed:bf:bf - UTF-16 surrogate 0xdb7f +5.2.5 n "\xed\xae\x80\xed\xb0\x80" - 6 ed:ae:80:ed:b0:80 - UTF-16 surrogate 0xdb80 +5.2.6 n "\xed\xae\x80\xed\xbf\xbf" - 6 ed:ae:80:ed:bf:bf - UTF-16 surrogate 0xdb80 +5.2.7 n "\xed\xaf\xbf\xed\xb0\x80" - 6 ed:af:bf:ed:b0:80 - UTF-16 surrogate 0xdbff +5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf" - 6 ed:af:bf:ed:bf:bf - UTF-16 surrogate 0xdbff +5.3 Other illegal code positions +5.3.1 n "\xef\xbf\xbe" - 3 ef:bf:be - byte order mark 0xfffe +# The ffff is illegal unless UTF8_ALLOW_FFFF +5.3.2 n "\xef\xbf\xbf" - 3 ef:bf:bf - character 0xffff +__EOMK__ + +# 104..181 +{ + my $WARNCNT; + my $id; + + local $SIG{__WARN__} = + sub { + print "# $id: @_"; + $WARNCNT++; + $WARNMSG = "@_"; + }; + + sub moan { + print "$id: @_"; + } + + sub test_unpack_U { + $WARNCNT = 0; + $WARNMSG = ""; + unpack('U*', $_[0]); + } + + for (@MK) { + if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) { + # print "# $_\n"; + } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) { + $id = $1; + my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) = + ($2, $3, $4, $5, $6, $7, $8); + my @hex = split(/:/, $hex); + unless (@hex == $byteslen) { + my $nhex = @hex; + moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n"; + } + { + use bytes; + my $bytesbyteslen = length($bytes); + unless ($bytesbyteslen == $byteslen) { + moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n"; + } + } + if ($okay eq 'y') { + test_unpack_U($bytes); + if ($WARNCNT) { + moan "unpack('U*') false negative\n"; + print "not "; + } + } elsif ($okay eq 'n') { + test_unpack_U($bytes); + if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) { + moan "unpack('U*') false positive\n"; + print "not "; + } + } + print "ok $test\n"; + $test++; + } else { + moan "unknown format\n"; + } + } +} diff --git a/t/op/ver.t b/t/op/ver.t index 08beced092..edfebd20ff 100755 --- a/t/op/ver.t +++ b/t/op/ver.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..23\n"; +print "1..28\n"; my $test = 1; @@ -155,3 +155,27 @@ print "ok $test\n"; ++$test; 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/t/op/write.t b/t/op/write.t index 5b01eb78b7..fc155a88c7 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..9\n"; +print "1..11\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -43,7 +43,7 @@ of huma... now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 1\n"; unlink 'Op_write.tmp'; } + { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } @@ -85,7 +85,7 @@ necessary now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 2\n"; unlink 'Op_write.tmp'; } + { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -129,7 +129,7 @@ necessary now is the time for all good men to come to\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 3\n"; unlink 'Op_write.tmp'; } + { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } @@ -184,7 +184,7 @@ $right = "fit\n"; if (`$CAT Op_write.tmp` eq $right) - { print "ok 6\n"; unlink 'Op_write.tmp'; } + { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 6\n"; } @@ -213,8 +213,53 @@ write (OUT4); close OUT4; if (`$CAT Op_write.tmp` eq "1\n") { print "ok 9\n"; - unlink "Op_write.tmp"; + 1 while unlink "Op_write.tmp"; } else { print "not ok 9\n"; } + +eval <<'EOFORMAT'; +format OUT10 = +@####.## @0###.## +$test1, $test1 +. +EOFORMAT + +open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT10); +close OUT10; + +$right = " 12.95 00012.95\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 10\n"; } + +eval <<'EOFORMAT'; +format OUT11 = +@0###.## +$test1 +@ 0# +$test1 +@0 # +$test1 +. +EOFORMAT + +open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT11); +close OUT11; + +$right = +"00012.95 +1 0# +10 #\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 11\n"; } diff --git a/t/pragma/constant.t b/t/pragma/constant.t index 450b4d02cf..f932976f60 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..73\n"; } +BEGIN { $| = 1; print "1..82\n"; } END {print "not ok 1\n" unless $loaded;} use constant 1.01; $loaded = 1; @@ -229,3 +229,23 @@ test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main: test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; @warnings = (); + + +use constant { + THREE => 3, + FAMILY => [ qw( John Jane Sally ) ], + AGES => { John => 33, Jane => 28, Sally => 3 }, + RFAM => [ [ qw( John Jane Sally ) ] ], + SPIT => sub { shift }, + PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ], +}; + +test 74, @{+FAMILY} == THREE; +test 75, @{+FAMILY} == @{RFAM->[0]}; +test 76, FAMILY->[2] eq RFAM->[0]->[2]; +test 77, AGES->{FAMILY->[1]} == 28; +test 78, PHFAM->{John} == AGES->{John}; +test 79, PHFAM->[3] == AGES->{FAMILY->[2]}; +test 80, @{+PHFAM} == SPIT->(THREE+1); +test 81, THREE**3 eq SPIT->(@{+FAMILY}**3); +test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE]; diff --git a/t/pragma/locale.t b/t/pragma/locale.t index c8a0df8724..61528b35c3 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -34,7 +34,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 +244,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 +273,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 +286,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 +330,7 @@ sub decode_encodings { } } else { push @enc, $_; + push @enc, "$_.UTF-8"; } } if ($^O eq 'os390') { @@ -347,32 +352,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 +414,8 @@ foreach my $locale (split(/\n/, $locales)) { setlocale(LC_ALL, "C"); +sub utf8locale { $_[0] =~ /utf-?8/i } + @Locale = sort @Locale; debug "# Locales = @Locale\n"; @@ -470,7 +506,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+)$/; @@ -623,6 +662,9 @@ foreach $Locale (@Locale) { } 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; @@ -646,7 +688,13 @@ foreach $Locale (@Locale) { } 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,15 +709,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"; @@ -685,7 +734,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -710,17 +759,18 @@ EOW } } -# Tell which locales were 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..116) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } if (@s) { @@ -732,7 +782,19 @@ if ($didwarn) { "#\t", $s, "\n#\n", "# tested okay.\n#\n", } else { - warn "# None of your locales was fully okay.\n"; + warn "# None of your locales were fully okay.\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"; } } diff --git a/t/pragma/overload.t b/t/pragma/overload.t index c7105dc9ca..bf24c07ec9 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -133,6 +133,7 @@ test ( $a eq "087"); # 29 test ( $b eq "88"); # 30 test (ref $a eq "Oscalar"); # 31 +undef $b; # Destroying updates tables too... eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t index 3ab8766892..a54075dd64 100755 --- a/t/pragma/sub_lval.t +++ b/t/pragma/sub_lval.t @@ -1,4 +1,4 @@ -print "1..46\n"; +print "1..49\n"; BEGIN { chdir 't' if -d 't'; @@ -334,8 +334,8 @@ 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 +sub lv1tmpr : lvalue { yyy } # is it read-only? $_ = undef; eval <<'EOE' or $_ = $@; @@ -427,3 +427,25 @@ $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"; + diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t index c3538c0cb5..8e4d296f5d 100755 --- a/t/pragma/utf8.t +++ b/t/pragma/utf8.t @@ -10,7 +10,7 @@ BEGIN { } } -print "1..99\n"; +print "1..105\n"; my $test = 1; @@ -42,6 +42,7 @@ sub nok_bytes { { use utf8; + $_ = ">\x{263A}<"; s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; ok $_, '>☺<'; @@ -104,215 +105,193 @@ sub nok_bytes { ok $1, '123alpha'; $test++; # 12 } -{ - use utf8; - - $_ = "\x{263A}>\x{263A}\x{263A}"; - ok length, 4; - $test++; # 13 - - ok length((m/>(.)/)[0]), 1; - $test++; # 14 - - ok length($&), 2; - $test++; # 15 +{ + # no use utf8 needed + $_ = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; + + ok length($_), 6; # 13 + $test++; - ok length($'), 1; - $test++; # 16 + ($a) = m/x(.)/; - ok length($`), 1; - $test++; # 17 + ok length($a), 1; # 14 + $test++; - ok length($1), 1; - $test++; # 18 + ok length($`), 2; # 15 + $test++; + ok length($&), 2; # 16 + $test++; + ok length($'), 2; # 17 + $test++; - ok length($tmp=$&), 2; - $test++; # 19 + ok length($1), 1; # 18 + $test++; - ok length($tmp=$'), 1; - $test++; # 20 + ok length($b=$`), 2; # 19 + $test++; - ok length($tmp=$`), 1; - $test++; # 21 + ok length($b=$&), 2; # 20 + $test++; - ok length($tmp=$1), 1; - $test++; # 22 + ok length($b=$'), 2; # 21 + $test++; - { - use bytes; + ok length($b=$1), 1; # 22 + $test++; - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 23 + ok $a, "\x{263A}"; # 23 + $test++; - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 24 + ok $`, "\x{263A}\x{263A}"; # 24 + $test++; - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 25 + ok $&, "x\x{263A}"; # 25 + $test++; - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 26 - } + ok $', "y\x{263A}"; # 26 + $test++; - ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 27 + ok $1, "\x{263A}"; # 27 + $test++; - ok_bytes $', pack("C*", 0342, 0230, 0272); - $test++; # 28 + ok_bytes $a, "\342\230\272"; # 28 + $test++; - ok_bytes $`, pack("C*", 0342, 0230, 0272); - $test++; # 29 + ok_bytes $1, "\342\230\272"; # 29 + $test++; - ok_bytes $1, pack("C*", 0342, 0230, 0272); - $test++; # 30 + ok_bytes $&, "x\342\230\272"; # 30 + $test++; { - use bytes; - no utf8; - - ok length, 10; - $test++; # 31 - - ok length((m/>(.)/)[0]), 1; - $test++; # 32 - - ok length($&), 2; - $test++; # 33 + use utf8; # required + $_ = chr(0x263A) . chr(0x263A) . 'x' . chr(0x263A) . 'y' . chr(0x263A); + } - ok length($'), 5; - $test++; # 34 + ok length($_), 6; # 31 + $test++; - ok length($`), 3; - $test++; # 35 + ($a) = m/x(.)/; - ok length($1), 1; - $test++; # 36 + ok length($a), 1; # 32 + $test++; - ok $&, pack("C*", ord(">"), 0342); - $test++; # 37 + ok length($`), 2; # 33 + $test++; - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 38 + ok length($&), 2; # 34 + $test++; - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 39 + ok length($'), 2; # 35 + $test++; - ok $1, pack("C*", 0342); - $test++; # 40 + ok length($1), 1; # 36 + $test++; - } + ok length($b=$`), 2; # 37 + $test++; + ok length($b=$&), 2; # 38 + $test++; - { - no utf8; - $_="\342\230\272>\342\230\272\342\230\272"; - } + ok length($b=$'), 2; # 39 + $test++; - ok length, 10; - $test++; # 41 + ok length($b=$1), 1; # 40 + $test++; - ok length((m/>(.)/)[0]), 1; - $test++; # 42 + ok $a, "\x{263A}"; # 41 + $test++; - ok length($&), 2; - $test++; # 43 + ok $`, "\x{263A}\x{263A}"; # 42 + $test++; - ok length($'), 1; - $test++; # 44 + ok $&, "x\x{263A}"; # 43 + $test++; - ok length($`), 1; - $test++; # 45 + ok $', "y\x{263A}"; # 44 + $test++; - ok length($1), 1; - $test++; # 46 + ok $1, "\x{263A}"; # 45 + $test++; - ok length($tmp=$&), 2; - $test++; # 47 + ok_bytes $a, "\342\230\272"; # 46 + $test++; - ok length($tmp=$'), 1; - $test++; # 48 + ok_bytes $1, "\342\230\272"; # 47 + $test++; - ok length($tmp=$`), 1; - $test++; # 49 + ok_bytes $&, "x\342\230\272"; # 48 + $test++; - ok length($tmp=$1), 1; - $test++; # 50 + $_ = "\342\230\272\342\230\272x\342\230\272y\342\230\272"; - { - use bytes; + ok length($_), 14; # 49 + $test++; - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 51 + ($a) = m/x(.)/; - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 52 + ok length($a), 1; # 50 + $test++; - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 53 + ok length($`), 6; # 51 + $test++; - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 54 - } - { - use bytes; - no utf8; + ok length($&), 2; # 52 + $test++; - ok length, 10; - $test++; # 55 + ok length($'), 6; # 53 + $test++; - ok length((m/>(.)/)[0]), 1; - $test++; # 56 + ok length($1), 1; # 54 + $test++; - ok length($&), 2; - $test++; # 57 + ok length($b=$`), 6; # 55 + $test++; - ok length($'), 5; - $test++; # 58 + ok length($b=$&), 2; # 56 + $test++; - ok length($`), 3; - $test++; # 59 + ok length($b=$'), 6; # 57 + $test++; - ok length($1), 1; - $test++; # 60 + ok length($b=$1), 1; # 58 + $test++; - ok $&, pack("C*", ord(">"), 0342); - $test++; # 61 + ok $a, "\342"; # 59 + $test++; - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 62 + ok $`, "\342\230\272\342\230\272"; # 60 + $test++; - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 63 + ok $&, "x\342"; # 61 + $test++; - ok $1, pack("C*", 0342); - $test++; # 64 + ok $', "\230\272y\342\230\272"; # 62 + $test++; - } + ok $1, "\342"; # 63 + $test++; +} +{ + use utf8; ok "\x{ab}" =~ /^\x{ab}$/, 1; - $test++; # 65 + $test++; # 64 } { use utf8; ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2); - $test++; # 66 + $test++; # 65 } { use utf8; my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); ok "@a", "1234 123 2345"; - $test++; # 67 + $test++; # 66 } { @@ -320,17 +299,22 @@ sub nok_bytes { my $x = chr(123); my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); ok "@a", "1234 2345"; - $test++; # 68 + $test++; # 67 } { # bug id 20001009.001 - my($a,$b); - { use bytes; $a = "\xc3\xa4"; } - { use utf8; $b = "\xe4"; } - { use bytes; ok_bytes $a, $b; $test++; } # 69 - { use utf8; nok $a, $b; $test++; } # 70 + 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++; # 68 + + { use utf8; print "not " if $a eq $b; } + print "ok $test\n"; $test++; # 69 } { @@ -340,7 +324,7 @@ sub nok_bytes { for (@x) { s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; my($latin) = /^(.+)(?:\s+\d)/; - print $latin eq "stra\337e" ? "ok $test\n" : + print $latin eq "stra\337e" ? "ok $test\n" : # 70, 71 "#latin[$latin]\nnot ok $test\n"; $test++; $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a @@ -350,64 +334,6 @@ sub nok_bytes { } { - # bug id 20000819.004 - - $_ = $dx = "\x{10f2}"; - s/($dx)/$dx$1/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $_ = $dx = "\x{10f2}"; - s/($dx)/$1$dx/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $dx = "\x{10f2}"; - $_ = "\x{10f2}\x{10f2}"; - s/($dx)($dx)/$1$2/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } -} - -{ - # bug id 20000323.056 - - use utf8; - - 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++; -} - -{ # bug id 20000427.003 use utf8; @@ -423,18 +349,7 @@ sub nok_bytes { } print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000901.092 - # test that undef left and right of utf8 results in a valid string - - my $a; - $a .= "\x{1ff}"; - print "not " unless $a eq "\x{1ff}"; - print "ok $test\n"; + print "ok $test\n"; # 72 $test++; } @@ -449,27 +364,27 @@ sub nok_bytes { print "not " unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; print "ok $test\n"; - $test++; + $test++; # 73 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++; + $test++; # 74 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++; + $test++; # 75 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++; + $test++; # 76 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++; + $test++; # 77 } { @@ -479,14 +394,14 @@ sub nok_bytes { my $smiley = "\x{263a}"; - for my $s ("\x{263a}", # 1 - $smiley, # 2 + for my $s ("\x{263a}", # 78 + $smiley, # 79 - "" . $smiley, # 3 - "" . "\x{263a}", # 4 + "" . $smiley, # 80 + "" . "\x{263a}", # 81 - $smiley . "", # 5 - "\x{263a}" . "", # 6 + $smiley . "", # 82 + "\x{263a}" . "", # 83 ) { my $length_chars = length($s); my $length_bytes; @@ -502,14 +417,14 @@ sub nok_bytes { $test++; } - for my $s ("\x{263a}" . "\x{263a}", # 7 - $smiley . $smiley, # 8 + for my $s ("\x{263a}" . "\x{263a}", # 84 + $smiley . $smiley, # 85 - "\x{263a}\x{263a}", # 9 - "$smiley$smiley", # 10 + "\x{263a}\x{263a}", # 86 + "$smiley$smiley", # 87 - "\x{263a}" x 2, # 11 - $smiley x 2, # 12 + "\x{263a}" x 2, # 88 + $smiley x 2, # 89 ) { my $length_chars = length($s); my $length_bytes; @@ -525,3 +440,117 @@ sub nok_bytes { $test++; } } + +{ + use utf8; + + print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 90 + + print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 91 + + print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 92 + + print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 93 + + print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 94 + + print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 95 + + print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; + print "ok $test\n"; + $test++; # 96 + + print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; + print "ok $test\n"; + $test++; # 97 +} + +{ + # the first half of 20001028.003 + + my $X = chr(1448); + my ($Y) = $X =~ /(.*)/; + print "not " unless length $Y == 1; + print "ok $test\n"; + $test++; # 98 +} + +{ + # 20001108.001 + + use utf8; + my $X = "Szab\x{f3},Bal\x{e1}zs"; + my $Y = $X; + $Y =~ s/(B)/$1/ for 0..3; + print "not " unless $Y eq $X; + print "ok $test\n"; + $test++; # 99 +} + +{ + # 20001114.001 + + use utf8; + use charnames ':full'; + my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}"; + print "not " unless ord($text) == 0xc4; + print "ok $test\n"; + $test++; # 100 +} + +{ + # 20001205.014 + + use utf8; + + my $a = "ABC\x{263A}"; + + my @b = split( //, $a ); + + print "not " unless @b == 4; + print "ok $test\n"; + $test++; # 101 + + print "not " unless length($b[3]) == 1; + print "ok $test\n"; + $test++; # 102 + + $a =~ s/^A/Z/; + print "not " unless length($a) == 4; + print "ok $test\n"; + $test++; # 103 +} + +{ + # the second half of 20001028.003 + + use utf8; + $X =~ s/^/chr(1488)/e; + print "not " unless length $X == 1; + print "ok $test\n"; + $test++; # 104 +} + +{ + # 20000517.001 + + my $x = "\x{100}A"; + + $x =~ s/A/B/; + + print "not " unless $x eq "\x{100}B" && length($x) == 2; + print "ok $test\n"; + $test++; # 105 +} diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 426820550c..5dd03801e1 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -47,6 +47,9 @@ Possible Y2K bug: about to append an integer to '19' [pp_concat] $x = "19$yy\n"; + Use of reference "%s" as array index [pp_aelem] + $x[\1] + __END__ # pp_hot.c [pp_print] use warnings 'unopened' ; @@ -151,6 +154,7 @@ open (FH, ">./xcv") ; my $a = <FH> ; no warnings 'io' ; $a = <FH> ; +close (FH) ; unlink $file ; EXPECT Filehandle FH opened only for output at - line 5. @@ -227,3 +231,17 @@ $x = "19" . $yy . "\n"; EXPECT Possible Y2K bug: about to append an integer to '19' at - line 12. Possible Y2K bug: about to append an integer to '19' at - line 13. +######## +# pp_hot.c [pp_aelem] +{ +use warnings 'misc'; +print $x[\1]; +} +{ +no warnings 'misc'; +print $x[\1]; +} + +EXPECT +OPTION regex +Use of reference ".*" as array index at - line 4. diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 2843c70ed3..e30637b0d4 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -3,6 +3,15 @@ untie attempted while %d inner references still exist [pp_untie] sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; + fileno() on unopened filehandle abc [pp_fileno] + $a = "abc"; fileno($a) + + binmode() on unopened filehandle abc [pp_binmode] + $a = "abc"; fileno($a) + + printf() on unopened filehandle abc [pp_prtf] + $a = "abc"; printf $a "fred" + Filehandle %s opened only for input [pp_leavewrite] format STDIN = . @@ -74,7 +83,7 @@ flock STDIN, 8; flock $a, 8; - lstat() on filehandle %s [pp_stat] + The stat preceding lstat() wasn't an lstat %s [pp_stat] lstat(STDIN); warn(warn_nl, "stat"); [pp_stat] @@ -203,7 +212,9 @@ syswrite() on closed filehandle STDIN at - line 6. # 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 @@ -225,11 +236,11 @@ flock STDIN, 8; flock FOO, 8; flock $a, 8; EXPECT -flock() on closed filehandle STDIN at - line 14. 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 17. -flock() on unopened filehandle at - line 18. +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' ; @@ -352,7 +363,7 @@ lstat(STDIN) ; no warnings 'io' ; lstat(STDIN) ; EXPECT -lstat() on filehandle STDIN at - line 13. +The stat preceding lstat() wasn't an lstat at - line 13. ######## # pp_sys.c [pp_fttext] use warnings qw(unopened closed) ; @@ -398,3 +409,11 @@ close F ; unlink $file ; EXPECT Filehandle F opened only for output at - line 12. +######## +# pp_sys.c [pp_binmode] +use warnings 'unopened' ; +binmode(BLARG); +$a = "BLERG";binmode($a); +EXPECT +binmode() on unopened filehandle BLARG at - line 3. +binmode() on unopened filehandle at - line 4. diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 index 6a2fe5446c..9a7dbafdee 100644 --- a/t/pragma/warn/utf8 +++ b/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/t/pragma/warnings.t b/t/pragma/warnings.t index 367449797d..872e6e1417 100644 --- a/t/pragma/warnings.t +++ b/t/pragma/warnings.t @@ -25,28 +25,37 @@ if (@ARGV) else { @w_files = sort glob("pragma/warn/*") } -foreach (@w_files) { +my $files = 0; +foreach my $file (@w_files) { next if /(~|\.orig|,v)$/; - open F, "<$_" or die "Cannot open $_: $!\n" ; + open F, "<$file" or die "Cannot open $file: $!\n" ; + my $line = 0; while (<F>) { + $line++; last if /^__END__/ ; } { local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; + $files++; + @prgs = (@prgs, $file, split "\n########\n", <F>) ; } close F ; } undef $/; -print "1..", scalar @prgs, "\n"; +print "1..", scalar(@prgs)-$files, "\n"; for (@prgs){ + unless (/\n/) + { + print "# From $_\n"; + next; + } my $switch = ""; my @temps = () ; if (s/^\s*-\w+//){ |