diff options
author | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
---|---|---|
committer | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
commit | 2618fad5bbb2d0182eb31ed805c41b543c513940 (patch) | |
tree | 52ba93338b13aefd02a0055304a9eccfa0e049f5 /contrib/perl5/t | |
parent | 77644ee620b6a79cf8c538abaf7cd301a875528d (diff) | |
download | FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.zip FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.tar.gz |
Vendor import of Perl 5.006
Diffstat (limited to 'contrib/perl5/t')
287 files changed, 21637 insertions, 1332 deletions
diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST index 3685c2a..0b674af 100755 --- a/contrib/perl5/t/TEST +++ b/contrib/perl5/t/TEST @@ -1,6 +1,6 @@ #!./perl -# Last change: Fri Jan 10 09:57:03 WET 1997 +# Last change: Fri May 28 03:16:57 BST 1999 # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. @@ -43,6 +43,9 @@ TESTING COMPILER -------------------------------------------------------------------------------- EOT + $ENV{PERLCC_TIMEOUT} = 120 + if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + $bad = 0; $good = 0; $total = @tests; @@ -150,12 +153,12 @@ EOT } } else { - $pct = sprintf("%.2f", $good / $total * 100); + $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00"; if ($bad == 1) { - warn "Failed 1 test script out of $total, $pct% okay.\n"; + warn "Failed 1 test script out of $files, $pct% okay.\n"; } else { - warn "Failed $bad test scripts out of $total, $pct% okay.\n"; + warn "Failed $bad test scripts out of $files, $pct% okay.\n"; } warn <<'SHRDLU'; ### Since not all tests were successful, you may want to run some diff --git a/contrib/perl5/t/UTEST b/contrib/perl5/t/UTEST new file mode 100755 index 0000000..b5f285b --- /dev/null +++ b/contrib/perl5/t/UTEST @@ -0,0 +1,195 @@ +#!./perl + +# Last change: Fri Jan 10 09:57:03 WET 1997 + +# This is written in a peculiar style, since we're trying to avoid +# most of the constructs we'll be testing for. + +$| = 1; + +if ($#ARGV >= 0 && $ARGV[0] eq '-v') { + $verbose = 1; + shift; +} + +chdir 't' if -f 't/TEST'; + +die "You need to run \"make test\" first to set things up.\n" + unless -e 'perl' or -e 'perl.exe'; + +#$ENV{PERL_DESTRUCT_LEVEL} = '2'; +$ENV{EMXSHELL} = 'sh'; # For OS/2 + +if ($#ARGV == -1) { + @ARGV = split(/[ \n]/, + `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); +} + +if ($^O eq 'os2' || $^O eq 'qnx') { + $sharpbang = 0; +} +else { + open(CONFIG, "../config.sh"); + while (<CONFIG>) { + if (/sharpbang='(.*)'/) { + $sharpbang = ($1 eq '#!'); + last; + } + } + close(CONFIG); +} + +%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); + +_testprogs('perl', @ARGV); +_testprogs('compile', @ARGV) if (-e "../testcompile"); + +sub _testprogs { + $type = shift @_; + @tests = @_; + + + print <<'EOT' if ($type eq 'compile'); +-------------------------------------------------------------------------------- +TESTING COMPILER +-------------------------------------------------------------------------------- +EOT + + $ENV{PERLCC_TIMEOUT} = 120 + if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + + $bad = 0; + $good = 0; + $total = @tests; + $files = 0; + $totmax = 0; + while ($test = shift @tests) { + + if ( $infinite{$test} && $type eq 'compile' ) { + print STDERR "$test creates infinite loop! Skipping.\n"; + next; + } + if ($test =~ /^$/) { + next; + } + $te = $test; + chop($te); + print "$te" . '.' x (18 - length($te)); + if (0) { + -x $test || (print "isn't executable.\n"); + + if ($type eq 'perl') { + open(RESULTS, "./$test |") || (print "can't run.\n"); } + else { + open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test -run -verbose dcf -log ../compilelog |") or print "can't compile.\n"; + } + } + else { + open(SCRIPT,"$test") or die "Can't run $test.\n"; + $_ = <SCRIPT>; + close(SCRIPT); + if (/#!..perl(.*)/) { + $switch = $1; + if ($^O eq 'VMS') { + # Must protect uppercase switches with "" on command line + $switch =~ s/-([A-Z]\S*)/"-$1"/g; + } + } + else { + $switch = ''; + } + + if ($type eq 'perl') { + open(RESULTS,"./perl$switch -I../lib -Mutf8 $test |") || (print "can't run.\n"); + } + else { + open(RESULTS, "./perl -I../lib ../utils/perlcc -Mutf8 ./$test -run -verbose dcf -log ../compilelog |") or print "can't compile.\n"; + } + } + $ok = 0; + $next = 0; + while (<RESULTS>) { + if ($verbose) { + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files += 1; + $next = 1; + $ok = 1; + } + else { + $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; + if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { + $next = $next + 1; + } + else { + $ok = 0; + } + } + } + } + close RESULTS; + $next = $next - 1; + if ($ok && $next == $max) { + if ($max) { + print "ok\n"; + $good = $good + 1; + } + else { + print "skipping test on this platform\n"; + $files -= 1; + } + } + else { + $next += 1; + print "FAILED at test $next\n"; + $bad = $bad + 1; + $_ = $test; + if (/^base/) { + die "Failed a basic test--cannot continue.\n"; + } + } + } + + if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + # XXX add mention of 'perlbug -ok' ? + } + else { + die "FAILED--no tests were run for some reason.\n"; + } + } + else { + $pct = sprintf("%.2f", $good / $total * 100); + if ($bad == 1) { + warn "Failed 1 test script out of $total, $pct% okay.\n"; + } + else { + warn "Failed $bad test scripts out of $total, $pct% okay.\n"; + } + warn <<'SHRDLU'; + ### Since not all tests were successful, you may want to run some + ### of them individually and examine any diagnostic messages they + ### produce. See the INSTALL document's section on "make test". + ### If you are testing the compiler, then ignore this message + ### and run + ### ./perl harness + ### in the directory ./t. +SHRDLU + warn <<'SHRDLU' if $good / $total > 0.8; + ### + ### Since most tests were successful, you have a good chance to + ### get information with better granularity by running + ### ./perl harness + ### in directory ./t. +SHRDLU + } + ($user,$sys,$cuser,$csys) = times; + print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", + $user,$sys,$cuser,$csys,$files,$totmax); +} +exit ($bad != 0); diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t index 8e2452d..d90d404 100755 --- a/contrib/perl5/t/base/lex.t +++ b/contrib/perl5/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..35\n"; +print "1..46\n"; $x = 'x'; @@ -116,6 +116,70 @@ $foo =~ s/^not /substr(<<EOF, 0, 0)/e; EOF print $foo; +# Tests for new extended control-character variables +# MJD 19990227 + +{ my $CX = "\cX"; + my $CXY ="\cXY"; + $ {$CX} = 17; + $ {$CXY} = 23; + if ($ {^XY} != 23) { print "not " } + print "ok 31\n"; + +# Does the syntax where we use the literal control character still work? + if (eval "\$ {\cX}" != 17 or $@) { print "not " } + print "ok 32\n"; + + eval "\$\cN = 24"; # Literal control character + if ($@ or ${"\cN"} != 24) { print "not " } + print "ok 33\n"; + if ($^N != 24) { print "not " } # Control character escape sequence + print "ok 34\n"; + +# Does the old UNBRACED syntax still do what it used to? + if ("$^XY" ne "17Y") { print "not " } + print "ok 35\n"; + + sub XX () { 6 } + $ {"\cN\cXX"} = 119; + $^N = 5; # This should be an unused ^Var. + $N = 5; + # The second caret here should be interpreted as an xor + if (($^N^XX) != 3) { print "not " } + print "ok 36\n"; +# if (($N ^ XX()) != 3) { print "not " } +# print "ok 32\n"; + + # These next two tests are trying to make sure that + # $^FOO is always global; it doesn't make sense to `my' it. + # + + eval 'my $^X;'; + print "not " unless index ($@, 'Can\'t use global $^X in "my"') > -1; + print "ok 37\n"; +# print "($@)\n" if $@; + + eval 'my $ {^XYZ};'; + print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1; + print "ok 38\n"; +# print "($@)\n" if $@; + +# Now let's make sure that caret variables are all forced into the main package. + package Someother; + $^N = 'Someother'; + $ {^Nostril} = 'Someother 2'; + $ {^M} = 'Someother 3'; + package main; + print "not " unless $^N eq 'Someother'; + print "ok 39\n"; + print "not " unless $ {^Nostril} eq 'Someother 2'; + print "ok 40\n"; + print "not " unless $ {^M} eq 'Someother 3'; + print "ok 41\n"; + + +} + # see if eval '', s///e, and heredocs mix sub T { @@ -125,7 +189,7 @@ sub T { print "ok $num\n"; } -my $test = 31; +my $test = 42; { # line 42 "plink" diff --git a/contrib/perl5/t/base/rs.t b/contrib/perl5/t/base/rs.t index 52a9572..021d699 100755 --- a/contrib/perl5/t/base/rs.t +++ b/contrib/perl5/t/base/rs.t @@ -24,7 +24,7 @@ $bar = <TESTFILE>; if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";} # Try a non line terminator -$/ = "3"; +$/ = 3; $bar = <TESTFILE>; if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";} @@ -122,8 +122,7 @@ if ($^O eq 'VMS') { if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";} close TESTFILE; - unlink "./foo.bar"; - unlink "./foo.com"; + 1 while unlink qw(foo.bar foo.com foo.fdl); } else { # Nobody else does this at the moment (well, maybe OS/390, but they can # put their own tests in) so we just punt diff --git a/contrib/perl5/t/base/term.t b/contrib/perl5/t/base/term.t index e96313d..6380694 100755 --- a/contrib/perl5/t/base/term.t +++ b/contrib/perl5/t/base/term.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; diff --git a/contrib/perl5/t/cmd/while.t b/contrib/perl5/t/cmd/while.t index 392c137..ecc15ed 100755 --- a/contrib/perl5/t/cmd/while.t +++ b/contrib/perl5/t/cmd/while.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $ - -print "1..15\n"; +print "1..22\n"; open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; @@ -128,3 +126,54 @@ while (1) { $i++; print "not " unless $` . $& . $' eq "abc"; print "ok $i\n"; + +# check that scope cleanup happens right when there's a continue block +{ + my $var = 16; + while (my $i = ++$var) { + next if $i == 17; + last if $i > 17; + my $i = 0; + } + continue { + print "ok ", $var-1, "\nok $i\n"; + } +} + +{ + local $l = 18; + { + local $l = 0 + } + continue { + print "ok $l\n" + } +} + +{ + local $l = 19; + my $x = 0; + while (!$x++) { + local $l = 0 + } + continue { + print "ok $l\n" + } +} + +$i = 20; +{ + while (1) { + my $x; + print $x if defined $x; + $x = "not "; + print "ok $i\n"; ++$i; + if ($i == 21) { + next; + } + last; + } + continue { + print "ok $i\n"; ++$i; + } +} diff --git a/contrib/perl5/t/comp/bproto.t b/contrib/perl5/t/comp/bproto.t new file mode 100755 index 0000000..01efb84 --- /dev/null +++ b/contrib/perl5/t/comp/bproto.t @@ -0,0 +1,44 @@ +#!./perl +# +# check if builtins behave as prototyped +# + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..10\n"; + +my $i = 1; + +sub foo {} +my $bar = "bar"; + +sub test_too_many { + eval $_[0]; + print "not " unless $@ =~ /^Too many arguments/; + printf "ok %d\n",$i++; +} + +sub test_no_error { + eval $_[0]; + print "not " if $@; + printf "ok %d\n",$i++; +} + +test_too_many($_) for split /\n/, +q[ defined(&foo, $bar); + undef(&foo, $bar); + uc($bar,$bar); +]; + +test_no_error($_) for split /\n/, +q[ scalar(&foo,$bar); + defined &foo, &foo, &foo; + undef &foo, $bar; + uc $bar,$bar; + grep(not($bar), $bar); + grep(not($bar, $bar), $bar); + grep((not $bar, $bar, $bar), $bar); +]; diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t index d2c64fe..dee5330 100755 --- a/contrib/perl5/t/comp/colon.t +++ b/contrib/perl5/t/comp/colon.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; diff --git a/contrib/perl5/t/comp/cpp.aux b/contrib/perl5/t/comp/cpp.aux index bb93d21..536268a 100755 --- a/contrib/perl5/t/comp/cpp.aux +++ b/contrib/perl5/t/comp/cpp.aux @@ -1,14 +1,10 @@ #!./perl -P -# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $ - print "1..3\n"; -#this is a comment #define MESS "ok 1\n" print MESS; -#If you capitalize, it's a comment. #ifdef MESS print "ok 2\n"; #else diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t index 86e7359..bbff38c 100755 --- a/contrib/perl5/t/comp/cpp.t +++ b/contrib/perl5/t/comp/cpp.t @@ -4,14 +4,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; if ( $^O eq 'MSWin32' or ($Config{'cppstdin'} =~ /\bcppstdin\b/) and ( ! -x $Config{'binexp'} . "/cppstdin") ) { - print "1..0\n"; + print "1..0 # Skip: \$Config{cppstdin} unavailable\n"; exit; # Cannot test till after install, alas. } diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t index db6a9b5..ee17088 100755 --- a/contrib/perl5/t/comp/proto.t +++ b/contrib/perl5/t/comp/proto.t @@ -11,12 +11,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; -print "1..87\n"; +print "1..107\n"; my $i = 1; @@ -384,11 +384,11 @@ print "ok ", $i++, "\n"; print "not " if defined prototype('CORE::system'); print "ok ", $i++, "\n"; -print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$'; +print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; print "ok ", $i++, "\n"; print "# CORE:Foo => ($p), \$@ => `$@'\nnot " - if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/; + if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; print "ok ", $i++, "\n"; # correctly note too-short parameter lists that don't end with '$', @@ -417,9 +417,52 @@ print "ok ", $i++, "\n"; # test if the (*) prototype allows barewords, constants, scalar expressions, # globs and globrefs (just as CORE::open() does), all under stricture sub star (*&) { &{$_[1]} } +sub star2 (**&) { &{$_[2]} } +sub BAR { "quux" } +sub Bar::BAZ { "quuz" } my $star = 'FOO'; star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; +star2 FOO, BAR, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; +star2(Bar::BAZ, FOO, sub { print "ok $i\n" + if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++; +star2 BAR(), FOO, sub { print "ok $i\n" + if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++; +star2(FOO, BAR(), sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++; +star2 "FOO", "BAR", sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; +star2("FOO", "BAR", sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++; +star2 $star, $star, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++; +star2($star, $star, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++; +star2 *FOO, *BAR, sub { print "ok $i\n" + if $_[0] eq \*FOO and $_[1] eq \*BAR }; $i++; +star2(*FOO, *BAR, sub { print "ok $i\n" + if $_[0] eq \*FOO and $_[1] eq \*BAR }); $i++; +star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" + if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }; $i++; +star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" + if $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'} }); $i++; + +# test scalarref prototype +sub sreftest (\$$) { + print "ok $_[1]\n" if ref $_[0]; +} +{ + no strict 'vars'; + sreftest my $sref, $i++; + sreftest($helem{$i}, $i++); + sreftest $aelem[0], $i++; +} diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t index 5c41f5c..1d92687 100755 --- a/contrib/perl5/t/comp/require.t +++ b/contrib/perl5/t/comp/require.t @@ -2,12 +2,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = ('.', '../lib'); + unshift @INC, ('.', '../lib'); } # don't make this lexical $i = 1; -print "1..4\n"; +print "1..20\n"; sub do_require { %INC = (); @@ -23,6 +23,74 @@ sub write_file { close REQ; } +eval {require 5.005}; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require 5.005 }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require 5.005; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { + require 5.005 +}; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +# new style version numbers + +eval { require v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require 10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +eval q{ use v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval q{ use 10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +my $ver = 5.005_63; +eval { require $ver; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +# check inaccurate fp +$ver = 10.2; +eval { require $ver; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.200\.0 required/; +print "ok ",$i++,"\n"; + +$ver = 10.000_02; +eval { require $ver; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; +print "ok ",$i++,"\n"; + +print "not " unless 5.5.1 gt v5.5; +print "ok ",$i++,"\n"; + +{ + use utf8; + print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; + print "ok ",$i++,"\n"; + + print "not " unless v7.15 eq "\x{7}\x{f}"; + print "ok ",$i++,"\n"; + + print "not " + unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; + print "ok ",$i++,"\n"; +} + # interaction with pod (see the eof) write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); require "bleah.pm"; @@ -45,7 +113,18 @@ do_require "1"; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; -END { unlink 'bleah.pm'; } +# do FILE shouldn't see any outside lexicals +my $x = "ok $i\n"; +write_file("bleah.do", <<EOT); +\$x = "not ok $i\\n"; +EOT +do "bleah.do"; +dofile(); +sub dofile { do "bleah.do"; }; +print $x; +$i++; + +END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; } # ***interaction with pod (don't put any thing after here)*** diff --git a/contrib/perl5/t/comp/script.t b/contrib/perl5/t/comp/script.t index d0c12e9..a9bc47d 100755 --- a/contrib/perl5/t/comp/script.t +++ b/contrib/perl5/t/comp/script.t @@ -6,7 +6,6 @@ print "1..3\n"; $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; $x = `$PERL -le "print 'ok';"`; -if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "print ""ok\n""";`; } if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} @@ -15,12 +14,10 @@ print try 'print "ok\n";'; print try "\n"; close try; $x = `$PERL Comp.script`; -if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. Comp.script`; } if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} $x = `$PERL <Comp.script`; -if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; } if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t index eb99680..f079eef 100755 --- a/contrib/perl5/t/comp/term.t +++ b/contrib/perl5/t/comp/term.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $ - # tests that aren't important enough for base.term -print "1..22\n"; +print "1..23\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; @@ -68,3 +66,7 @@ if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} $a = "+{ \$a=>'foo'}"; $a = eval $a; if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} + +$a = "{ 0x01 => 'foo'}->{0x01}"; +$a = eval $a; +if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t index a6ce2a4..1f5fae3 100755 --- a/contrib/perl5/t/comp/use.t +++ b/contrib/perl5/t/comp/use.t @@ -2,12 +2,18 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..14\n"; +print "1..27\n"; my $i = 1; +eval "use 5.000"; # implicit semicolon +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; eval "use 5.000;"; if ($@) { @@ -44,9 +50,7 @@ unless ($@) { print "ok ",$i++,"\n"; - -use lib; # I know that this module will be there. - +{ use lib } # check that subparse saves pending tokens local $lib::VERSION = 1.0; @@ -99,3 +103,68 @@ print "ok ",$i++,"\n"; print "not " if $INC[0] eq "freda"; print "ok ",$i++,"\n"; + +{ + local $lib::VERSION = 35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = '35.36'; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = v35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib v100\.105 required--this is only v35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) { + print "not "; + } + print "ok ",$i++,"\n"; +} diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness index f6d94de..e1a4dd7 100644 --- a/contrib/perl5/t/harness +++ b/contrib/perl5/t/harness @@ -5,29 +5,77 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; # so children will see it too + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; # so children will see it too } use lib '../lib'; use Test::Harness; -$Test::Harness::switches = ""; # Too much noise otherwise +$Test::Harness::switches = ""; # Too much noise otherwise $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; +#fudge DATA for now. +%datahandle = qw( + lib/bigint.t 1 + lib/bigintpm.t 1 + lib/bigfloat.t 1 + lib/bigfloatpm.t 1 + op/gv.t 1 + lib/complex.t 1 + lib/ph.t 1 + lib/soundex.t 1 + op/misc.t 1 + op/runlevel.t 1 + op/tie.t 1 + op/lex_assign.t 1 + pragma/subs.t 1 + ); + +foreach (keys %datahandle) { + unlink "$_.t"; +} + @tests = @ARGV; @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests; Test::Harness::runtests @tests; +exit(0) unless -e "../testcompile"; -%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +%infinite = qw ( + op/bop.t 1 + lib/hostname.t 1 + op/lex_assign.t 1 + lib/ph.t 1 + ); + +my $dhwrapper = <<'EOT'; +open DATA,"<".__FILE__; +until (($_=<DATA>) =~ /^__END__/) {}; +EOT @tests = grep (!$infinite{$_}, @tests); +@tests = map { + my $new = $_; + if ($datahandle{$_} && !( -f "$new.t") ) { + $new .= '.t'; + local(*F, *T); + open(F,"<$_") or die "Can't open $_: $!"; + open(T,">$new") or die "Can't open $new: $!"; + print T $dhwrapper, <F>; + close F; + close T; + } + $new; + } @tests; + +print "The tests ", join(' ', keys(%infinite)), + " generate infinite loops! Skipping!\n"; -if (-e "../testcompile") -{ - print "The tests ", join(' ', keys(%infinite)), - " generate infinite loops! Skipping!\n"; +$ENV{'HARNESS_COMPILE_TEST'} = 1; +$ENV{'PERLCC_TIMEOUT'} = 120 unless $ENV{'PERLCC_TIMEOUT'}; - $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; +Test::Harness::runtests @tests; +foreach (keys %datahandle) { + unlink "$_.t"; } diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index c6565dc..d6093f9 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -1,24 +1,33 @@ #!./perl -print "1..6\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..20\n"; + +use File::Spec; + +my $devnull = File::Spec->devnull; -open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); +open(try, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; if ($^O eq 'MSWin32') { - $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; + $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`; } else { - $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; + $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`; } if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`; + $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`; } else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; + $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`; } if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} @@ -30,7 +39,7 @@ else { } if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} -@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); +@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); while (<>) { $y .= $. . $_; if (eof()) { @@ -43,17 +52,74 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '>Io_argv1.tmp') or die "Can't open temp file: $!"; close try; -@ARGV = 'Io.argv.tmp'; +open(try, '>Io_argv2.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '.bak'; $/ = undef; +my $i = 6; while (<>) { - s/^/ok 6\n/; + s/^/ok $i\n/; + ++$i; print; } -open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '<Io_argv1.tmp') or die "Can't open temp file: $!"; +print while <try>; +open(try, '<Io_argv2.tmp') or die "Can't open temp file: $!"; print while <try>; close try; +undef $^I; + +eof try or print 'not '; +print "ok 8\n"; + +eof NEVEROPENED or print 'not '; +print "ok 9\n"; + +open STDIN, 'Io_argv1.tmp' or die $!; +@ARGV = (); +!eof() or print 'not '; +print "ok 10\n"; + +<> eq "ok 6\n" or print 'not '; +print "ok 11\n"; + +open STDIN, $devnull or die $!; +@ARGV = (); +eof() or print 'not '; +print "ok 12\n"; + +@ARGV = ('Io_argv1.tmp'); +!eof() or print 'not '; +print "ok 13\n"; + +@ARGV = ($devnull, $devnull); +!eof() or print 'not '; +print "ok 14\n"; + +close ARGV or die $!; +eof() or print 'not '; +print "ok 15\n"; + +{ + local $/; + open F, 'Io_argv1.tmp' or die; + <F>; # set $. = 1 + open F, $devnull or die; + print "not " unless defined(<F>); + print "ok 16\n"; + print "not " if defined(<F>); + print "ok 17\n"; + print "not " if defined(<F>); + print "ok 18\n"; + open F, $devnull or die; # restart cycle again + print "not " unless defined(<F>); + print "ok 19\n"; + print "not " if defined(<F>); + print "ok 20\n"; + close F; +} -END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } +END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp.bak', 'Io_argv2.tmp', 'Io_argv2.tmp.bak' } diff --git a/contrib/perl5/t/io/dup.t b/contrib/perl5/t/io/dup.t index f312671..af13d4d 100755 --- a/contrib/perl5/t/io/dup.t +++ b/contrib/perl5/t/io/dup.t @@ -37,3 +37,4 @@ else { system 'cat Io.dup' } unlink 'Io.dup'; print STDOUT "ok 6\n"; + diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index f09d66c..970e2f3 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; @@ -12,12 +12,16 @@ use Config; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'mint'); -print "1..28\n"; +if (defined &Win32::IsWinNT && Win32::IsWinNT()) { + $Is_Dosish = '' if Win32::FsType() eq 'NTFS'; +} + +print "1..29\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -if ($^O eq 'MSWin32') { `del tmp 2>nul`; `mkdir tmp`; } +if ($^O eq 'MSWin32') { `rmdir /s /q tmp 2>nul`; `mkdir tmp`; } else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } chdir './tmp'; `/bin/rm -rf a b c x` if -x '/bin/rm'; @@ -54,28 +58,35 @@ elsif (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} -if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} +$newmode = $^O eq 'MSWin32' ? 0444 : 0777; +if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} -elsif (($mode & 0777) == 0777) {print "ok 7\n";} +elsif (($mode & 0777) == $newmode) {print "ok 7\n";} else {print "not ok 7\n";} +$newmode = 0700; +if ($^O eq 'MSWin32') { + chmod 0444, 'x'; + $newmode = 0666; +} + if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} -elsif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} +elsif ((chmod $newmode,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} -elsif (($mode & 0777) == 0700) {print "ok 9\n";} +elsif (($mode & 0777) == $newmode) {print "ok 9\n";} else {print "not ok 9\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} -elsif (($mode & 0777) == 0700) {print "ok 10\n";} +elsif (($mode & 0777) == $newmode) {print "ok 10\n";} else {print "not ok 10\n";} if ($Is_Dosish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; } @@ -93,6 +104,7 @@ if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} $blksize,$blocks) = stat('a'); if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} $delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem +chmod 0777, 'b'; $foo = (utime 500000000,500000000 + $delta,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -141,25 +153,45 @@ else { truncate "Iofs.tmp", 0; if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"} open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; + binmode FH; { select FH; $| = 1; select STDOUT } - print FH "helloworld\n"; - truncate FH, 5; - if ($^O eq 'dos') { + { + use strict; + print FH "x\n" x 200; + truncate(FH, 200) or die "Can't truncate FH: $!"; + } + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } - if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} + if (-s "Iofs.tmp" == 200) {print "ok 25\n"} else {print "not ok 25\n"} truncate FH, 0; - if ($^O eq 'dos') { + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} close FH; } +# check if rename() can be used to just change case of filename +chdir './tmp'; +open(fh,'>x') || die "Can't create x"; +close(fh); +rename('x', 'X'); +print 'not ' unless -e 'X'; +print "ok 27\n"; +unlink 'X'; +chdir $wd || die "Can't cd back to $wd"; + # check if rename() works on directories rename 'tmp', 'tmp1' or print "not "; -print "ok 27\n"; --d 'tmp1' or print "not "; print "ok 28\n"; +-d 'tmp1' or print "not "; +print "ok 29\n"; END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/contrib/perl5/t/io/nargv.t b/contrib/perl5/t/io/nargv.t new file mode 100755 index 0000000..fb13857 --- /dev/null +++ b/contrib/perl5/t/io/nargv.t @@ -0,0 +1,63 @@ +#!./perl + +print "1..5\n"; + +my $j = 1; +for $i ( 1,2,5,4,3 ) { + $file = mkfiles($i); + open(FH, "> $file") || die "can't create $file: $!"; + print FH "not ok " . $j++ . "\n"; + close(FH) || die "Can't close $file: $!"; +} + + +{ + local *ARGV; + local $^I = '.bak'; + local $_; + @ARGV = mkfiles(1..3); + $n = 0; + while (<>) { + print STDOUT "# initial \@ARGV: [@ARGV]\n"; + if ($n++ == 2) { + other(); + } + show(); + } +} + +$^I = undef; +@ARGV = mkfiles(1..3); +$n = 0; +while (<>) { + print STDOUT "#final \@ARGV: [@ARGV]\n"; + if ($n++ == 2) { + other(); + } + show(); +} + +sub show { + #warn "$ARGV: $_"; + s/^not //; + print; +} + +sub other { + print STDOUT "# Calling other\n"; + local *ARGV; + local *ARGVOUT; + local $_; + @ARGV = mkfiles(5, 4); + while (<>) { + print STDOUT "# inner \@ARGV: [@ARGV]\n"; + show(); + } +} + +sub mkfiles { + my @files = map { "scratch$_" } @_; + return wantarray ? @files : $files[-1]; +} + +END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/contrib/perl5/t/io/open.t b/contrib/perl5/t/io/open.t new file mode 100755 index 0000000..30db598 --- /dev/null +++ b/contrib/perl5/t/io/open.t @@ -0,0 +1,282 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# $RCSfile$ +$| = 1; +use warnings; +$Is_VMS = $^O eq 'VMS'; + +print "1..66\n"; + +my $test = 1; + +sub ok { print "ok $test\n"; $test++ } + +# my $file tests + +# 1..9 +{ + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(my $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); +} + +# 10..12 +{ + print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; +} + +# 13..15 +{ + print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; +} + +# 16..18 +{ + print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 19..23 +{ + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 24..26 +if ($Is_VMS) { + for (24..26) { print "ok $_ # skipped: not Unix fork\n"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" +EOC + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 27..30 +if ($Is_VMS) { + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" +EOC + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; +} + +# 31..32 +eval <<'EOE' and print "not "; +open my $f, '<&', 'afile'; +1; +EOE +ok; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +ok; + +# local $file tests + +# 33..41 +{ + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(local $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); +} + +# 42..44 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; +} + +# 45..47 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; +} + +# 48..50 +{ + print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 51..55 +{ + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 56..58 +if ($Is_VMS) { + for (56..58) { print "ok $_ # skipped: not Unix fork\n"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" +EOC + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 59..62 +if ($Is_VMS) { + for (59..62) { print "ok $_ # skipped: not Unix fork\n"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" +EOC + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; +} + +# 63..64 +eval <<'EOE' and print "not "; +open local $f, '<&', 'afile'; +1; +EOE +ok; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +ok; + +# 65..66 +{ + local *F; + for (1..2) { + open(F, "echo #foo|") or print "not "; + print <F>; + close F; + } + ok; + for (1..2) { + open(F, "-|", "echo #foo") or print "not "; + print <F>; + close F; + } + ok; +} diff --git a/contrib/perl5/t/io/openpid.t b/contrib/perl5/t/io/openpid.t new file mode 100755 index 0000000..80c6bde --- /dev/null +++ b/contrib/perl5/t/io/openpid.t @@ -0,0 +1,86 @@ +#!./perl + +##################################################################### +# +# Test for process id return value from open +# Ronald Schmidt (The Software Path) RonaldWS@software-path.com +# +##################################################################### + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + if ($^O eq 'dos') { + print "1..0 # Skip: no multitasking\n"; + exit 0; + } +} + + +use FileHandle; +use Config; +autoflush STDOUT 1; +$SIG{PIPE} = 'IGNORE'; + +print "1..10\n"; + +$perl = qq[$^X "-I../lib"]; + +# +# commands run 4 perl programs. Two of these programs write a +# short message to STDOUT and exit. Two of these programs +# read from STDIN. One reader never exits and must be killed. +# the other reader reads one line, waits a few seconds and then +# exits to test the waitpid function. +# +$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . + qq/print qq[first process\\n]; sleep 30;"/; +$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . + qq/print qq[second process\\n]; sleep 30;"/; +$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN +$cmd4 = qq/$perl -e "print scalar <>;"/; + +#warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n"; + +# start the processes +$pid1 = open(FH1, "$cmd1 |") or print "not "; +print "ok 1\n"; +$pid2 = open(FH2, "$cmd2 |") or print "not "; +print "ok 2\n"; +$pid3 = open(FH3, "| $cmd3") or print "not "; +print "ok 3\n"; +$pid4 = open(FH4, "| $cmd4") or print "not "; +print "ok 4\n"; + +print "# pids were $pid1, $pid2, $pid3, $pid4\n"; + +my $killsig = 'HUP'; +$killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/; + +# get message from first process and kill it +chomp($from_pid1 = scalar(<FH1>)); +print "# child1 returned [$from_pid1]\nnot " + unless $from_pid1 eq 'first process'; +print "ok 5\n"; +$kill_cnt = kill $killsig, $pid1; +print "not " unless $kill_cnt == 1; +print "ok 6\n"; + +# get message from second process and kill second process and reader process +chomp($from_pid2 = scalar(<FH2>)); +print "# child2 returned [$from_pid2]\nnot " + unless $from_pid2 eq 'second process'; +print "ok 7\n"; +$kill_cnt = kill $killsig, $pid2, $pid3; +print "not " unless $kill_cnt == 2; +print "ok 8\n"; + +# send one expected line of text to child process and then wait for it +autoflush FH4 1; +print FH4 "ok 9\n"; +print "ok 9 # skip VMS\n" if $^O eq 'VMS'; +print "# waiting for process $pid4 to exit\n"; +$reap_pid = waitpid $pid4, 0; +print "# reaped pid $reap_pid != $pid4\nnot " + unless $reap_pid == $pid4; +print "ok 10\n"; diff --git a/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t index ba7a9b0..4559624 100755 --- a/contrib/perl5/t/io/pipe.t +++ b/contrib/perl5/t/io/pipe.t @@ -1,57 +1,65 @@ #!./perl -# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $ - BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; unless ($Config{'d_fork'}) { - print "1..0\n"; + print "1..0 # Skip: no fork\n"; exit 0; } } $| = 1; -print "1..12\n"; +print "1..15\n"; +# External program 'tr' assumed. open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); print PIPE "Xk 1\n"; print PIPE "oY 2\n"; close PIPE; -if (open(PIPE, "-|")) { - while(<PIPE>) { - s/^not //; - print; +if ($^O eq 'vmesa') { + # Doesn't work, yet. + for (3..6) { + print "ok $_ # skipped\n"; + } +} else { + if (open(PIPE, "-|")) { + while(<PIPE>) { + s/^not //; + print; + } + close PIPE; # avoid zombies which disrupt test 12 + } + else { + # External program 'echo' assumed. + print STDOUT "not ok 3\n"; + exec 'echo', 'not ok 4'; } - close PIPE; # avoid zombies which disrupt test 12 -} -else { - print STDOUT "not ok 3\n"; - exec 'echo', 'not ok 4'; -} -pipe(READER,WRITER) || die "Can't open pipe"; + pipe(READER,WRITER) || die "Can't open pipe"; -if ($pid = fork) { - close WRITER; - while(<READER>) { - s/^not //; - y/A-Z/a-z/; - print; + if ($pid = fork) { + close WRITER; + while(<READER>) { + s/^not //; + y/A-Z/a-z/; + print; + } + close READER; # avoid zombies which disrupt test 12 + } + else { + die "Couldn't fork" unless defined $pid; + close READER; + print WRITER "not ok 5\n"; + open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; + close WRITER; + # External program 'echo' assumed. + exec 'echo', 'not ok 6'; } - close READER; # avoid zombies which disrupt test 12 -} -else { - die "Couldn't fork" unless defined $pid; - close READER; - print WRITER "not ok 5\n"; - open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; - close WRITER; - exec 'echo', 'not ok 6'; } - +wait; # Collect from $pid pipe(READER,WRITER) || die "Can't open pipe"; close READER; @@ -72,24 +80,25 @@ print "ok 8\n"; # STDOUT. Someone should modify tests #9 to #12 to work with VMS. if ($^O eq 'VMS') { - print "ok 9\n"; - print "ok 10\n"; - print "ok 11\n"; - print "ok 12\n"; + print "ok 9 # skipped\n"; + print "ok 10 # skipped\n"; + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; exit; } -if ($Config{d_sfio} || $^O eq machten || $^O eq beos) { +if ($Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || $^O eq 'posix-bc') { # Sfio doesn't report failure when closing a broken pipe # that has pending output. Go figure. MachTen doesn't either, # but won't write to broken pipes, so nothing's pending at close. # BeOS will not write to broken pipes, either. - print "ok 9\n"; + # Nor does POSIX-BC. + print "ok 9 # skipped\n"; } else { local $SIG{PIPE} = 'IGNORE'; open NIL, '|true' or die "open failed: $!"; - sleep 2; + sleep 5; print NIL 'foo' or die "print failed: $!"; if (close NIL) { print "not ok 9\n"; @@ -99,6 +108,14 @@ else { } } +if ($^O eq 'vmesa') { + # These don't work, yet. + print "ok 10 # skipped\n"; + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; + exit; +} + # check that errno gets forced to 0 if the piped program exited non-zero open NIL, '|exit 23;' or die "fork failed: $!"; $! = 1; @@ -115,21 +132,45 @@ else { print "ok 10\n"; } -# check that status for the correct process is collected -wait; # Collect from $pid -my $zombie = fork or exit 37; -my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; -$SIG{ALRM} = sub { return }; -alarm(1); -my $close = close FH; -if ($? == 13*256 && ! length $close && ! $!) { - print "ok 11\n"; -} else { - print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; -}; -my $wait = wait; -if ($? == 37*256 && $wait == $zombie && ! $!) { - print "ok 12\n"; +if ($^O eq 'mpeix') { + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; } else { - print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; + # check that status for the correct process is collected + my $zombie = fork or exit 37; + my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; + $SIG{ALRM} = sub { return }; + alarm(1); + my $close = close FH; + if ($? == 13*256 && ! length $close && ! $!) { + print "ok 11\n"; + } else { + print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; + }; + my $wait = wait; + if ($? == 37*256 && $wait == $zombie && ! $!) { + print "ok 12\n"; + } else { + print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; + } +} + +# Test new semantics for missing command in piped open +# 19990114 M-J. Dominus mjd@plover.com +{ local *P; + print (((open P, "| " ) ? "not " : ""), "ok 13\n"); + print (((open P, " |" ) ? "not " : ""), "ok 14\n"); +} + +# check that status is unaffected by implicit close +{ + local(*NIL); + open NIL, '|exit 23;' or die "fork failed: $!"; + $? = 42; + # NIL implicitly closed here +} +if ($? != 42) { + print "# status $?, expected 42\nnot "; } +print "ok 15\n"; +$? = 0; diff --git a/contrib/perl5/t/io/print.t b/contrib/perl5/t/io/print.t index 180b1e8..0578ee6 100755 --- a/contrib/perl5/t/io/print.t +++ b/contrib/perl5/t/io/print.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: print.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:32 $ - -print "1..16\n"; +print "1..18\n"; $foo = 'STDOUT'; print $foo "ok 1\n"; @@ -30,3 +28,7 @@ print "ok","11"; @x = ("ok","12\nok","13\nok"); @y = ("15\nok","16"); print @x,"14\nok",@y; +{ + local $\ = "ok 17\n# null =>[\000]\nok 18\n"; + print ""; +} diff --git a/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t index 83904e8..b89aefb 100755 --- a/contrib/perl5/t/io/tell.t +++ b/contrib/perl5/t/io/tell.t @@ -1,13 +1,16 @@ #!./perl -# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $ +# $RCSfile: tell.t,v $$Revision$$Date$ -print "1..13\n"; +print "1..21\n"; $TST = 'tst'; +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin'); + open($TST, '../Configure') || (die "Can't open ../Configure"); -binmode $TST if $^O eq 'MSWin32'; +binmode $TST if $Is_Dosish; if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$TST>; @@ -42,3 +45,40 @@ if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } + +if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } + +$curline = $.; +open(other, '../Configure') || (die "Can't open ../Configure"); +binmode other if $^O eq 'MSWin32'; + +{ + local($.); + + if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; } + + tell other; + if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; } + + $. = 5; + scalar <other>; + if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; } +} + +if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; } + +{ + local($.); + + scalar <other>; + if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; } +} + +if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } + +{ + local($.); + + tell other; + if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } +} diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t index fb5a984..05e5c70 100755 --- a/contrib/perl5/t/lib/abbrev.t +++ b/contrib/perl5/t/lib/abbrev.t @@ -4,7 +4,7 @@ print "1..7\n"; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Text::Abbrev; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t new file mode 100755 index 0000000..3e16dce --- /dev/null +++ b/contrib/perl5/t/lib/ansicolor.t @@ -0,0 +1,73 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test suite for the Term::ANSIColor Perl module. Before `make install' is +# performed this script should be runnable with `make test'. After `make +# install' it should work as `perl test.pl'. + +############################################################################ +# Ensure module can be loaded +############################################################################ + +BEGIN { $| = 1; print "1..7\n" } +END { print "not ok 1\n" unless $loaded } +use Term::ANSIColor qw(:constants color colored); +$loaded = 1; +print "ok 1\n"; + + +############################################################################ +# Test suite +############################################################################ + +# Test simple color attributes. +if (color ('blue on_green', 'bold') eq "\e[34;42;1m") { + print "ok 2\n"; +} else { + print "not ok 2\n"; +} + +# Test colored. +if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") { + print "ok 3\n"; +} else { + print "not ok 3\n"; +} + +# Test the constants. +if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") { + print "ok 4\n"; +} else { + print "not ok 4\n"; +} + +# Test AUTORESET. +$Term::ANSIColor::AUTORESET = 1; +if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") { + print "ok 5\n"; +} else { + print "not ok 5\n"; +} + +# Test EACHLINE. +$Term::ANSIColor::EACHLINE = "\n"; +if (colored ("test\n\ntest", 'bold') + eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") { + print "ok 6\n"; +} else { + print colored ("test\n\ntest", 'bold'), "\n"; + print "not ok 6\n"; +} + +# Test EACHLINE with multiple trailing delimiters. +$Term::ANSIColor::EACHLINE = "\r\n"; +if (colored ("test\ntest\r\r\n\r\n", 'bold') + eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") { + print "ok 7\n"; +} else { + print "not ok 7\n"; +} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t index 0391b7b..e38c7e7 100755 --- a/contrib/perl5/t/lib/anydbm.t +++ b/contrib/perl5/t/lib/anydbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } require AnyDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT @@ -12,6 +12,9 @@ use Fcntl; print "1..12\n"; +$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); + unlink <Op_dbmx*>; umask(0); @@ -22,7 +25,7 @@ $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx*>; } -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { +if ($Is_Dosish) { print "ok 2 # Skipped: different file permission semantics\n"; } else { @@ -115,7 +118,30 @@ print ($size > 0 ? "ok 9\n" : "not ok 9\n"); print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +if ($h{''} eq 'bar') { + print "ok 12\n" ; +} +else { + if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) { + ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ; + $major =~ s/^0+// ; + $minor =~ s/^0+// ; + $patch =~ s/^0+// ; + $compact = "$major.$minor.$patch" ; + # + # anydbm.t test 12 will fail when AnyDBM_File uses the combination of + # DB_File and Berkeley DB 2.4.10 (or greater). + # You are using DB_File $DB_File::VERSION and Berkeley DB $compact + # + # 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. + # + print "ok 12 # skipped: db v$compact, no null key support\n" ; + } + else { + print "not ok 12\n" ; + } +} untie %h; if ($^O eq 'VMS') { diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t new file mode 100755 index 0000000..eb8c8c4 --- /dev/null +++ b/contrib/perl5/t/lib/attrs.t @@ -0,0 +1,138 @@ +#!./perl + +# Regression tests for attrs.pm and the C<sub x : attrs> syntax. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + eval 'require attrs; 1' or do { + print "1..0\n"; + exit 0; + } +} + +sub NTESTS () ; + +my $test, $ntests; +BEGIN {$ntests=0} +$test=0; +my $failed = 0; + +print "1..".NTESTS."\n"; + +eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t2 { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t3 ($) : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t4 : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon1; +eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon2; +eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon3; +eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my @attrs = attrs::get($anon3 ? $anon3 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e1 ($) : plugh ;'; +unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; +unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; +unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e4 ($) : plugh + xyzzy ;'; +unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +{ + my $w = "" ; + local $SIG{__WARN__} = sub {$w = @_[0]} ; + eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; + (print "not "), $failed=1 if $@; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} + (print "not "), $failed=1 + if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} +} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t index b1622a8..3bf690b 100755 --- a/contrib/perl5/t/lib/autoloader.t +++ b/contrib/perl5/t/lib/autoloader.t @@ -3,10 +3,10 @@ BEGIN { chdir 't' if -d 't'; $dir = "auto-$$"; - @INC = ("./$dir", "../lib"); + unshift @INC, ("./$dir", "../lib"); } -print "1..9\n"; +print "1..11\n"; # First we must set up some autoloader files mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; @@ -88,12 +88,33 @@ print "ok 8\n"; print "not " unless $foo->bazmarkhianish($1) eq 'foo'; print "ok 9\n"; +# test recursive autoloads +open(F, ">$dir/auto/Foo/a.al") or die; +print F <<'EOT'; +package Foo; +BEGIN { b() } +sub a { print "ok 11\n"; } +1; +EOT +close(F); + +open(F, ">$dir/auto/Foo/b.al") or die; +print F <<'EOT'; +package Foo; +sub b { print "ok 10\n"; } +1; +EOT +close(F); +Foo::a(); + # cleanup END { return unless $dir && -d $dir; unlink "$dir/auto/Foo/foo.al"; unlink "$dir/auto/Foo/bar.al"; unlink "$dir/auto/Foo/bazmarkhian.al"; +unlink "$dir/auto/Foo/a.al"; +unlink "$dir/auto/Foo/b.al"; rmdir "$dir/auto/Foo"; rmdir "$dir/auto"; rmdir "$dir"; diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t index a02aa32..478e26a 100755 --- a/contrib/perl5/t/lib/basename.t +++ b/contrib/perl5/t/lib/basename.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use File::Basename qw(fileparse basename dirname); diff --git a/contrib/perl5/t/lib/bigfloat.t b/contrib/perl5/t/lib/bigfloat.t new file mode 100755 index 0000000..8e0a0ef --- /dev/null +++ b/contrib/perl5/t/lib/bigfloat.t @@ -0,0 +1,408 @@ +#!./perl + +BEGIN { @INC = '../lib' } +require "bigfloat.pl"; + +$test = 0; +$| = 1; +print "1..355\n"; +while (<DATA>) { + chop; + if (/^&/) { + $f = $_; + } elsif (/^\$.*/) { + eval "$_;"; + } else { + ++$test; + @args = split(/:/,$_,99); + $ans = pop(@args); + $try = "$f('" . join("','", @args) . "');"; + if (($ans1 = eval($try)) eq $ans) { + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&fnorm +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN +0:+0E+0 ++0:+0E+0 ++00:+0E+0 ++0 0 0:+0E+0 +000000 0000000 00000:+0E+0 +-0:+0E+0 +-0000:+0E+0 ++1:+1E+0 ++01:+1E+0 ++001:+1E+0 ++00000100000:+1E+5 +123456789:+123456789E+0 +-1:-1E+0 +-01:-1E+0 +-001:-1E+0 +-123456789:-123456789E+0 +-00000100000:-1E+5 +123.456a:NaN +123.456:+123456E-3 +0.01:+1E-2 +.002:+2E-3 +-0.0003:-3E-4 +-.0000000004:-4E-10 +123456E2:+123456E+2 +123456E-2:+123456E-2 +-123456E2:-123456E+2 +-123456E-2:-123456E-2 +1e1:+1E+1 +2e-11:+2E-11 +-3e111:-3E+111 +-4e-1111:-4E-1111 +&fneg +abd:NaN ++0:+0E+0 ++1:-1E+0 +-1:+1E+0 ++123456789:-123456789E+0 +-123456789:+123456789E+0 ++123.456789:-123456789E-6 +-123456.789:+123456789E-3 +&fabs +abc:NaN ++0:+0E+0 ++1:+1E+0 +-1:+1E+0 ++123456789:+123456789E+0 +-123456789:+123456789E+0 ++123.456789:+123456789E-6 +-123456.789:+123456789E-3 +&fround +$bigfloat::rnd_mode = 'trunc' ++10123456789:5:+10123E+6 +-10123456789:5:-10123E+6 ++10123456789:9:+101234567E+2 +-10123456789:9:-101234567E+2 ++101234500:6:+101234E+3 +-101234500:6:-101234E+3 +$bigfloat::rnd_mode = 'zero' ++20123456789:5:+20123E+6 +-20123456789:5:-20123E+6 ++20123456789:9:+201234568E+2 +-20123456789:9:-201234568E+2 ++201234500:6:+201234E+3 +-201234500:6:-201234E+3 +$bigfloat::rnd_mode = '+inf' ++30123456789:5:+30123E+6 +-30123456789:5:-30123E+6 ++30123456789:9:+301234568E+2 +-30123456789:9:-301234568E+2 ++301234500:6:+301235E+3 +-301234500:6:-301234E+3 +$bigfloat::rnd_mode = '-inf' ++40123456789:5:+40123E+6 +-40123456789:5:-40123E+6 ++40123456789:9:+401234568E+2 +-40123456789:9:-401234568E+2 ++401234500:6:+401234E+3 +-401234500:6:-401235E+3 +$bigfloat::rnd_mode = 'odd' ++50123456789:5:+50123E+6 +-50123456789:5:-50123E+6 ++50123456789:9:+501234568E+2 +-50123456789:9:-501234568E+2 ++501234500:6:+501235E+3 +-501234500:6:-501235E+3 +$bigfloat::rnd_mode = 'even' ++60123456789:5:+60123E+6 +-60123456789:5:-60123E+6 ++60123456789:9:+601234568E+2 +-60123456789:9:-601234568E+2 ++601234500:6:+601234E+3 +-601234500:6:-601234E+3 +&ffround +$bigfloat::rnd_mode = 'trunc' ++1.23:-1:+12E-1 +-1.23:-1:-12E-1 ++1.27:-1:+12E-1 +-1.27:-1:-12E-1 ++1.25:-1:+12E-1 +-1.25:-1:-12E-1 ++1.35:-1:+13E-1 +-1.35:-1:-13E-1 +-0.006:-1:+0E+0 +-0.006:-2:+0E+0 +$bigfloat::rnd_mode = 'zero' ++2.23:-1:+22E-1 +-2.23:-1:-22E-1 ++2.27:-1:+23E-1 +-2.27:-1:-23E-1 ++2.25:-1:+22E-1 +-2.25:-1:-22E-1 ++2.35:-1:+23E-1 +-2.35:-1:-23E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = '+inf' ++3.23:-1:+32E-1 +-3.23:-1:-32E-1 ++3.27:-1:+33E-1 +-3.27:-1:-33E-1 ++3.25:-1:+33E-1 +-3.25:-1:-32E-1 ++3.35:-1:+34E-1 +-3.35:-1:-33E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = '-inf' ++4.23:-1:+42E-1 +-4.23:-1:-42E-1 ++4.27:-1:+43E-1 +-4.27:-1:-43E-1 ++4.25:-1:+42E-1 +-4.25:-1:-43E-1 ++4.35:-1:+43E-1 +-4.35:-1:-44E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-7E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = 'odd' ++5.23:-1:+52E-1 +-5.23:-1:-52E-1 ++5.27:-1:+53E-1 +-5.27:-1:-53E-1 ++5.25:-1:+53E-1 +-5.25:-1:-53E-1 ++5.35:-1:+53E-1 +-5.35:-1:-53E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-7E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = 'even' ++6.23:-1:+62E-1 +-6.23:-1:-62E-1 ++6.27:-1:+63E-1 +-6.27:-1:-63E-1 ++6.25:-1:+62E-1 +-6.25:-1:-62E-1 ++6.35:-1:+64E-1 +-6.35:-1:-64E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +&fcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 +&fadd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++1:+0:+1E+0 ++0:+1:+1E+0 ++1:+1:+2E+0 +-1:+0:-1E+0 ++0:-1:-1E+0 +-1:-1:-2E+0 +-1:+1:+0E+0 ++1:-1:+0E+0 ++9:+1:+1E+1 ++99:+1:+1E+2 ++999:+1:+1E+3 ++9999:+1:+1E+4 ++99999:+1:+1E+5 ++999999:+1:+1E+6 ++9999999:+1:+1E+7 ++99999999:+1:+1E+8 ++999999999:+1:+1E+9 ++9999999999:+1:+1E+10 ++99999999999:+1:+1E+11 ++10:-1:+9E+0 ++100:-1:+99E+0 ++1000:-1:+999E+0 ++10000:-1:+9999E+0 ++100000:-1:+99999E+0 ++1000000:-1:+999999E+0 ++10000000:-1:+9999999E+0 ++100000000:-1:+99999999E+0 ++1000000000:-1:+999999999E+0 ++10000000000:-1:+9999999999E+0 ++123456789:+987654321:+111111111E+1 +-123456789:+987654321:+864197532E+0 +-123456789:-987654321:-111111111E+1 ++123456789:-987654321:-864197532E+0 +&fsub +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++1:+0:+1E+0 ++0:+1:-1E+0 ++1:+1:+0E+0 +-1:+0:-1E+0 ++0:-1:+1E+0 +-1:-1:+0E+0 +-1:+1:-2E+0 ++1:-1:+2E+0 ++9:+1:+8E+0 ++99:+1:+98E+0 ++999:+1:+998E+0 ++9999:+1:+9998E+0 ++99999:+1:+99998E+0 ++999999:+1:+999998E+0 ++9999999:+1:+9999998E+0 ++99999999:+1:+99999998E+0 ++999999999:+1:+999999998E+0 ++9999999999:+1:+9999999998E+0 ++99999999999:+1:+99999999998E+0 ++10:-1:+11E+0 ++100:-1:+101E+0 ++1000:-1:+1001E+0 ++10000:-1:+10001E+0 ++100000:-1:+100001E+0 ++1000000:-1:+1000001E+0 ++10000000:-1:+10000001E+0 ++100000000:-1:+100000001E+0 ++1000000000:-1:+1000000001E+0 ++10000000000:-1:+10000000001E+0 ++123456789:+987654321:-864197532E+0 +-123456789:+987654321:-111111111E+1 +-123456789:-987654321:+864197532E+0 ++123456789:-987654321:+111111111E+1 +&fmul +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++0:+1:+0E+0 ++1:+0:+0E+0 ++0:-1:+0E+0 +-1:+0:+0E+0 ++123456789123456789:+0:+0E+0 ++0:+123456789123456789:+0E+0 +-1:-1:+1E+0 +-1:+1:-1E+0 ++1:-1:-1E+0 ++1:+1:+1E+0 ++2:+3:+6E+0 +-2:+3:-6E+0 ++2:-3:-6E+0 +-2:-3:+6E+0 ++111:+111:+12321E+0 ++10101:+10101:+102030201E+0 ++1001001:+1001001:+1002003002001E+0 ++100010001:+100010001:+10002000300020001E+0 ++10000100001:+10000100001:+100002000030000200001E+0 ++11111111111:+9:+99999999999E+0 ++22222222222:+9:+199999999998E+0 ++33333333333:+9:+299999999997E+0 ++44444444444:+9:+399999999996E+0 ++55555555555:+9:+499999999995E+0 ++66666666666:+9:+599999999994E+0 ++77777777777:+9:+699999999993E+0 ++88888888888:+9:+799999999992E+0 ++99999999999:+9:+899999999991E+0 +&fdiv +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0E+0 ++1:+0:NaN ++0:-1:+0E+0 +-1:+0:NaN ++1:+1:+1E+0 +-1:-1:+1E+0 ++1:-1:-1E+0 +-1:+1:-1E+0 ++1:+2:+5E-1 ++2:+1:+2E+0 ++10:+5:+2E+0 ++100:+4:+25E+0 ++1000:+8:+125E+0 ++10000:+16:+625E+0 ++10000:-16:-625E+0 ++999999999999:+9:+111111111111E+0 ++999999999999:+99:+10101010101E+0 ++999999999999:+999:+1001001001E+0 ++999999999999:+9999:+100010001E+0 ++999999999999999:+99999:+10000100001E+0 ++1000000000:+9:+1111111111111111111111111111111111111111E-31 ++2000000000:+9:+2222222222222222222222222222222222222222E-31 ++3000000000:+9:+3333333333333333333333333333333333333333E-31 ++4000000000:+9:+4444444444444444444444444444444444444444E-31 ++5000000000:+9:+5555555555555555555555555555555555555556E-31 ++6000000000:+9:+6666666666666666666666666666666666666667E-31 ++7000000000:+9:+7777777777777777777777777777777777777778E-31 ++8000000000:+9:+8888888888888888888888888888888888888889E-31 ++9000000000:+9:+1E+9 ++35500000:+113:+3141592920353982300884955752212389380531E-34 ++71000000:+226:+3141592920353982300884955752212389380531E-34 ++106500000:+339:+3141592920353982300884955752212389380531E-34 ++1000000000:+3:+3333333333333333333333333333333333333333E-31 +$bigfloat::div_scale = 20 ++1000000000:+9:+11111111111111111111E-11 ++2000000000:+9:+22222222222222222222E-11 ++3000000000:+9:+33333333333333333333E-11 ++4000000000:+9:+44444444444444444444E-11 ++5000000000:+9:+55555555555555555556E-11 ++6000000000:+9:+66666666666666666667E-11 ++7000000000:+9:+77777777777777777778E-11 ++8000000000:+9:+88888888888888888889E-11 ++9000000000:+9:+1E+9 ++35500000:+113:+314159292035398230088E-15 ++71000000:+226:+314159292035398230088E-15 ++106500000:+339:+31415929203539823009E-14 ++1000000000:+3:+33333333333333333333E-11 +$bigfloat::div_scale = 40 +&fsqrt ++0:+0E+0 +-1:NaN +-2:NaN +-16:NaN +-123.456:NaN ++1:+1E+0 ++1.44:+12E-1 ++2:+141421356237309504880168872420969807857E-38 ++4:+2E+0 ++16:+4E+0 ++100:+1E+1 ++123.456:+1111107555549866648462149404118219234119E-38 ++15241.383936:+123456E-3 diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t new file mode 100755 index 0000000..5d97f1b --- /dev/null +++ b/contrib/perl5/t/lib/bigfltpm.t @@ -0,0 +1,463 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::BigFloat; + +$test = 0; +$| = 1; +print "1..362\n"; +while (<DATA>) { + chop; + if (s/^&//) { + $f = $_; + } elsif (/^\$.*/) { + eval "$_;"; + } else { + ++$test; + if (m|^(.*?):(/.+)$|) { + $ans = $2; + @args = split(/:/,$1,99); + } + else { + @args = split(/:/,$_,99); + $ans = pop(@args); + } + $try = "\$x = new Math::BigFloat \"$args[0]\";"; + if ($f eq "fnorm"){ + $try .= "\$x+0;"; + } elsif ($f eq "fneg") { + $try .= "-\$x;"; + } elsif ($f eq "fabs") { + $try .= "abs \$x;"; + } elsif ($f eq "fround") { + $try .= "0+\$x->fround($args[1]);"; + } elsif ($f eq "ffround") { + $try .= "0+\$x->ffround($args[1]);"; + } elsif ($f eq "fsqrt") { + $try .= "0+\$x->fsqrt;"; + } else { + $try .= "\$y = new Math::BigFloat \"$args[1]\";"; + if ($f eq "fcmp") { + $try .= "\$x <=> \$y;"; + } elsif ($f eq "fadd") { + $try .= "\$x + \$y;"; + } elsif ($f eq "fsub") { + $try .= "\$x - \$y;"; + } elsif ($f eq "fmul") { + $try .= "\$x * \$y;"; + } elsif ($f eq "fdiv") { + $try .= "\$x / \$y;"; + } else { warn "Unknown op"; } + } + #print ">>>",$try,"<<<\n"; + $ans1 = eval $try; + if ($ans =~ m|^/(.*)$|) { + my $pat = $1; + if ($ans1 =~ /$pat/) { + print "ok $test\n"; + } + else { + print "not ok $test\n"; + print "# '$try' expected: /$pat/ got: '$ans1'\n"; + } + } + elsif ("$ans1" eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&fnorm +abc:NaN. + 1 a:NaN. +1bcd2:NaN. +11111b:NaN. ++1z:NaN. +-1z:NaN. +0:0. ++0:0. ++00:0. ++0 0 0:0. +000000 0000000 00000:0. +-0:0. +-0000:0. ++1:1. ++01:1. ++001:1. ++00000100000:100000. +123456789:123456789. +-1:-1. +-01:-1. +-001:-1. +-123456789:-123456789. +-00000100000:-100000. +123.456a:NaN. +123.456:123.456 +0.01:.01 +.002:.002 +-0.0003:-.0003 +-.0000000004:-.0000000004 +123456E2:12345600. +123456E-2:1234.56 +-123456E2:-12345600. +-123456E-2:-1234.56 +1e1:10. +2e-11:.00000000002 +-3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. +-4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 +&fneg +abd:NaN. ++0:0. ++1:-1. +-1:1. ++123456789:-123456789. +-123456789:123456789. ++123.456789:-123.456789 +-123456.789:123456.789 +&fabs +abc:NaN. ++0:0. ++1:1. +-1:1. ++123456789:123456789. +-123456789:123456789. ++123.456789:123.456789 +-123456.789:123456.789 +&fround +$Math::BigFloat::rnd_mode = 'trunc' ++10123456789:5:10123000000 +-10123456789:5:-10123000000 ++10123456789:9:10123456700 +-10123456789:9:-10123456700 ++101234500:6:101234000 +-101234500:6:-101234000 +$Math::BigFloat::rnd_mode = 'zero' ++20123456789:5:20123000000 +-20123456789:5:-20123000000 ++20123456789:9:20123456800 +-20123456789:9:-20123456800 ++201234500:6:201234000 +-201234500:6:-201234000 +$Math::BigFloat::rnd_mode = '+inf' ++30123456789:5:30123000000 +-30123456789:5:-30123000000 ++30123456789:9:30123456800 +-30123456789:9:-30123456800 ++301234500:6:301235000 +-301234500:6:-301234000 +$Math::BigFloat::rnd_mode = '-inf' ++40123456789:5:40123000000 +-40123456789:5:-40123000000 ++40123456789:9:40123456800 +-40123456789:9:-40123456800 ++401234500:6:401234000 +-401234500:6:-401235000 +$Math::BigFloat::rnd_mode = 'odd' ++50123456789:5:50123000000 +-50123456789:5:-50123000000 ++50123456789:9:50123456800 +-50123456789:9:-50123456800 ++501234500:6:501235000 +-501234500:6:-501235000 +$Math::BigFloat::rnd_mode = 'even' ++60123456789:5:60123000000 +-60123456789:5:-60123000000 ++60123456789:9:60123456800 +-60123456789:9:-60123456800 ++601234500:6:601234000 +-601234500:6:-601234000 +&ffround +$Math::BigFloat::rnd_mode = 'trunc' ++1.23:-1:1.2 +-1.23:-1:-1.2 ++1.27:-1:1.2 +-1.27:-1:-1.2 ++1.25:-1:1.2 +-1.25:-1:-1.2 ++1.35:-1:1.3 +-1.35:-1:-1.3 +-0.006:-1:0 +-0.006:-2:0 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'zero' ++2.23:-1:/2.2(?:0{5}\d+)? +-2.23:-1:/-2.2(?:0{5}\d+)? ++2.27:-1:/2.(?:3|29{5}\d+) +-2.27:-1:/-2.(?:3|29{5}\d+) ++2.25:-1:/2.2(?:0{5}\d+)? +-2.25:-1:/-2.2(?:0{5}\d+)? ++2.35:-1:/2.(?:3|29{5}\d+) +-2.35:-1:/-2.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = '+inf' ++3.23:-1:/3.2(?:0{5}\d+)? +-3.23:-1:/-3.2(?:0{5}\d+)? ++3.27:-1:/3.(?:3|29{5}\d+) +-3.27:-1:/-3.(?:3|29{5}\d+) ++3.25:-1:/3.(?:3|29{5}\d+) +-3.25:-1:/-3.2(?:0{5}\d+)? ++3.35:-1:/3.(?:4|39{5}\d+) +-3.35:-1:/-3.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = '-inf' ++4.23:-1:/4.2(?:0{5}\d+)? +-4.23:-1:/-4.2(?:0{5}\d+)? ++4.27:-1:/4.(?:3|29{5}\d+) +-4.27:-1:/-4.(?:3|29{5}\d+) ++4.25:-1:/4.2(?:0{5}\d+)? +-4.25:-1:/-4.(?:3|29{5}\d+) ++4.35:-1:/4.(?:3|29{5}\d+) +-4.35:-1:/-4.(?:4|39{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'odd' ++5.23:-1:/5.2(?:0{5}\d+)? +-5.23:-1:/-5.2(?:0{5}\d+)? ++5.27:-1:/5.(?:3|29{5}\d+) +-5.27:-1:/-5.(?:3|29{5}\d+) ++5.25:-1:/5.(?:3|29{5}\d+) +-5.25:-1:/-5.(?:3|29{5}\d+) ++5.35:-1:/5.(?:3|29{5}\d+) +-5.35:-1:/-5.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'even' ++6.23:-1:/6.2(?:0{5}\d+)? +-6.23:-1:/-6.2(?:0{5}\d+)? ++6.27:-1:/6.(?:3|29{5}\d+) +-6.27:-1:/-6.(?:3|29{5}\d+) ++6.25:-1:/6.2(?:0{5}\d+)? +-6.25:-1:/-6.2(?:0{5}\d+)? ++6.35:-1:/6.(?:4|39{5}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +&fcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 +-1.1:0:-1 ++0:-1.1:1 ++1.1:+0:1 ++0:+1.1:-1 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 +&fadd +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++1:+0:1. ++0:+1:1. ++1:+1:2. +-1:+0:-1. ++0:-1:-1. +-1:-1:-2. +-1:+1:0. ++1:-1:0. ++9:+1:10. ++99:+1:100. ++999:+1:1000. ++9999:+1:10000. ++99999:+1:100000. ++999999:+1:1000000. ++9999999:+1:10000000. ++99999999:+1:100000000. ++999999999:+1:1000000000. ++9999999999:+1:10000000000. ++99999999999:+1:100000000000. ++10:-1:9. ++100:-1:99. ++1000:-1:999. ++10000:-1:9999. ++100000:-1:99999. ++1000000:-1:999999. ++10000000:-1:9999999. ++100000000:-1:99999999. ++1000000000:-1:999999999. ++10000000000:-1:9999999999. ++123456789:+987654321:1111111110. +-123456789:+987654321:864197532. +-123456789:-987654321:-1111111110. ++123456789:-987654321:-864197532. +&fsub +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++1:+0:1. ++0:+1:-1. ++1:+1:0. +-1:+0:-1. ++0:-1:1. +-1:-1:0. +-1:+1:-2. ++1:-1:2. ++9:+1:8. ++99:+1:98. ++999:+1:998. ++9999:+1:9998. ++99999:+1:99998. ++999999:+1:999998. ++9999999:+1:9999998. ++99999999:+1:99999998. ++999999999:+1:999999998. ++9999999999:+1:9999999998. ++99999999999:+1:99999999998. ++10:-1:11. ++100:-1:101. ++1000:-1:1001. ++10000:-1:10001. ++100000:-1:100001. ++1000000:-1:1000001. ++10000000:-1:10000001. ++100000000:-1:100000001. ++1000000000:-1:1000000001. ++10000000000:-1:10000000001. ++123456789:+987654321:-864197532. +-123456789:+987654321:-1111111110. +-123456789:-987654321:864197532. ++123456789:-987654321:1111111110. +&fmul +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++0:+1:0. ++1:+0:0. ++0:-1:0. +-1:+0:0. ++123456789123456789:+0:0. ++0:+123456789123456789:0. +-1:-1:1. +-1:+1:-1. ++1:-1:-1. ++1:+1:1. ++2:+3:6. +-2:+3:-6. ++2:-3:-6. +-2:-3:6. ++111:+111:12321. ++10101:+10101:102030201. ++1001001:+1001001:1002003002001. ++100010001:+100010001:10002000300020001. ++10000100001:+10000100001:100002000030000200001. ++11111111111:+9:99999999999. ++22222222222:+9:199999999998. ++33333333333:+9:299999999997. ++44444444444:+9:399999999996. ++55555555555:+9:499999999995. ++66666666666:+9:599999999994. ++77777777777:+9:699999999993. ++88888888888:+9:799999999992. ++99999999999:+9:899999999991. +&fdiv +abc:abc:NaN. +abc:+1:abc:NaN. ++1:abc:NaN. ++0:+0:NaN. ++0:+1:0. ++1:+0:NaN. ++0:-1:0. +-1:+0:NaN. ++1:+1:1. +-1:-1:1. ++1:-1:-1. +-1:+1:-1. ++1:+2:.5 ++2:+1:2. ++10:+5:2. ++100:+4:25. ++1000:+8:125. ++10000:+16:625. ++10000:-16:-625. ++999999999999:+9:111111111111. ++999999999999:+99:10101010101. ++999999999999:+999:1001001001. ++999999999999:+9999:100010001. ++999999999999999:+99999:10000100001. ++1000000000:+9:111111111.1111111111111111111111111111111 ++2000000000:+9:222222222.2222222222222222222222222222222 ++3000000000:+9:333333333.3333333333333333333333333333333 ++4000000000:+9:444444444.4444444444444444444444444444444 ++5000000000:+9:555555555.5555555555555555555555555555556 ++6000000000:+9:666666666.6666666666666666666666666666667 ++7000000000:+9:777777777.7777777777777777777777777777778 ++8000000000:+9:888888888.8888888888888888888888888888889 ++9000000000:+9:1000000000. ++35500000:+113:314159.2920353982300884955752212389380531 ++71000000:+226:314159.2920353982300884955752212389380531 ++106500000:+339:314159.2920353982300884955752212389380531 ++1000000000:+3:333333333.3333333333333333333333333333333 +$Math::BigFloat::div_scale = 20 ++1000000000:+9:111111111.11111111111 ++2000000000:+9:222222222.22222222222 ++3000000000:+9:333333333.33333333333 ++4000000000:+9:444444444.44444444444 ++5000000000:+9:555555555.55555555556 ++6000000000:+9:666666666.66666666667 ++7000000000:+9:777777777.77777777778 ++8000000000:+9:888888888.88888888889 ++9000000000:+9:1000000000. ++35500000:+113:314159.292035398230088 ++71000000:+226:314159.292035398230088 ++106500000:+339:314159.29203539823009 ++1000000000:+3:333333333.33333333333 +$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:1. ++1.44:1.2 ++2:1.41421356237309504880168872420969807857 ++4:2. ++16:4. ++100:10. ++123.456:11.11107555549866648462149404118219234119 ++15241.383936:123.456 diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t index 034c5c6..d2d520e 100755 --- a/contrib/perl5/t/lib/bigint.t +++ b/contrib/perl5/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } require "bigint.pl"; $test = 0; diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t index e7cac26..ae362e2 100755 --- a/contrib/perl5/t/lib/bigintpm.t +++ b/contrib/perl5/t/lib/bigintpm.t @@ -2,14 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::BigInt; $test = 0; $| = 1; -print "1..247\n"; +print "1..278\n"; while (<DATA>) { chop; if (s/^&//) { @@ -27,20 +27,32 @@ while (<DATA>) { $try .= "abs \$x;"; } else { $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq bcmp){ + if ($f eq "bcmp"){ $try .= "\$x <=> \$y;"; - }elsif ($f eq badd){ + }elsif ($f eq "badd"){ $try .= "\$x + \$y;"; - }elsif ($f eq bsub){ + }elsif ($f eq "bsub"){ $try .= "\$x - \$y;"; - }elsif ($f eq bmul){ + }elsif ($f eq "bmul"){ $try .= "\$x * \$y;"; - }elsif ($f eq bdiv){ + }elsif ($f eq "bdiv"){ $try .= "\$x / \$y;"; - }elsif ($f eq bmod){ + }elsif ($f eq "bmod"){ $try .= "\$x % \$y;"; - }elsif ($f eq bgcd){ + }elsif ($f eq "bgcd"){ $try .= "Math::BigInt::bgcd(\$x, \$y);"; + }elsif ($f eq "blsft"){ + $try .= "\$x << \$y;"; + }elsif ($f eq "brsft"){ + $try .= "\$x >> \$y;"; + }elsif ($f eq "band"){ + $try .= "\$x & \$y;"; + }elsif ($f eq "bior"){ + $try .= "\$x | \$y;"; + }elsif ($f eq "bxor"){ + $try .= "\$x ^ \$y;"; + }elsif ($f eq "bnot"){ + $try .= "~\$x;"; } else { warn "Unknown op"; } } #print ">>>",$try,"<<<\n"; @@ -52,7 +64,24 @@ while (<DATA>) { print "# '$try' expected: '$ans' got: '$ans1'\n"; } } -} +} + +{ + use Math::BigInt ':constant'; + + $test++; + print "not " + unless 2**150 eq "+1427247692705959881058285969449495136382746624"; + print "ok $test\n"; + $test++; + @a = (); + for ($i = 1; $i < 10; $i++) { + push @a, $i; + } + print "not " unless "@a" eq "+1 +2 +3 +4 +5 +6 +7 +8 +9"; + print "ok $test\n"; +} + __END__ &bnorm abc:NaN @@ -93,29 +122,29 @@ abc:NaN +123456789:+123456789 -123456789:+123456789 &bcmp -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 -1:+0:-1 -+0:-1:+1 -+1:+0:+1 ++0:-1:1 ++1:+0:1 +0:+1:-1 -1:+1:-1 -+1:-1:+1 --1:-1:+0 -+1:+1:+0 -+123:+123:+0 -+123:+12:+1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 +12:+123:-1 --123:-123:+0 +-123:-123:0 -123:-12:-1 --12:-123:+1 +-12:-123:1 +123:+124:-1 -+124:+123:+1 --123:-124:+1 ++124:+123:1 +-123:-124:1 -124:-123:-1 -+100:+5:+1 ++100:+5:1 &badd abc:abc:NaN abc:+0:NaN @@ -311,3 +340,38 @@ abc:+0:NaN +3:+2:+1 +100:+625:+25 +4096:+81:+1 +&blsft +abc:abc:NaN ++2:+2:+8 ++1:+32:+4294967296 ++1:+48:+281474976710656 ++8:-2:NaN +&brsft +abc:abc:NaN ++8:+2:+2 ++4294967296:+32:+1 ++281474976710656:+48:+1 ++2:-2:NaN +&band +abc:abc:NaN ++8:+2:+0 ++281474976710656:+0:+0 ++281474976710656:+1:+0 ++281474976710656:+281474976710656:+281474976710656 +&bior +abc:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+281474976710656 +&bxor +abc:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+0 +&bnot +abc:NaN ++0:-1 ++8:-9 ++281474976710656:-281474976710657 diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t index 86df161..e3cba5f 100755 --- a/contrib/perl5/t/lib/cgi-form.t +++ b/contrib/perl5/t/lib/cgi-form.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..17\n"; } @@ -44,16 +44,16 @@ test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})"); test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">), "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather\n), +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather), "checkbox()"); test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast), "checkbox()"); test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast), "checkbox()"); test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast), "checkbox()"); test(13,radio_group(-name=>'game') eq diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t index ad8b968..b4cd568 100755 --- a/contrib/perl5/t/lib/cgi-function.t +++ b/contrib/perl5/t/lib/cgi-function.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..24\n"; } diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 6a7ff1e..43d41ec 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -5,12 +5,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; } BEGIN {$| = 1; print "1..20\n"; } -BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; - $eol = "\r\n" if $^O eq 'os390'; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; @@ -18,6 +17,9 @@ print "ok 1\n"; ######################### End of black magic. +my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; +my $crlf = $CGI::CRLF; + # util sub test { local($^W) = 0; @@ -38,10 +40,11 @@ test(7,h1({-align=>'CENTER'},['fred','agnes']) eq local($") = '-'; test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation"); } -test(9,header() eq "Content-Type: text/html${eol}${eol}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${eol}${eol}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${eol}Content-Type: image/gif${eol}${eol}","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${eol}Content-Type: text/html${eol}${eol}","header()"); + +test(9,header() eq "Content-Type: text/html$crlf$crlf","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif$crlf$crlf","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif$crlf$crlf","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html$crlf$crlf","header()"); test(13,start_html() ."\n" eq <<END,"start_html()"); <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> <HTML><HEAD><TITLE>Untitled Document</TITLE> @@ -62,8 +65,11 @@ END ; test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s, "header(-cookie)"); test(18,start_h3 eq '<H3>'); test(19,end_h3 eq '</H3>'); test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); + + + diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t index 8c70c40..9e8cdc2 100755 --- a/contrib/perl5/t/lib/cgi-request.t +++ b/contrib/perl5/t/lib/cgi-request.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..31\n"; } @@ -25,15 +25,16 @@ sub test { } # Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{HTTP_LOVE} = 'true'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()"); diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t new file mode 100755 index 0000000..7643390 --- /dev/null +++ b/contrib/perl5/t/lib/charnames.t @@ -0,0 +1,74 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +$| = 1; +print "1..12\n"; + +use charnames ':full'; + +print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; +print "ok 1\n"; + +{ + use bytes; # UTEST can switch utf8 on + + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' +use charnames ":full"; +"Here: \N{CYRILLIC SMALL LETTER BE}!"; +1 +EOE + or $@ !~ /above 0xFF/; + print "ok 2\n"; + # print "# \$res=$res \$\@='$@'\n"; + + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' +use charnames 'cyrillic'; +"Here: \N{Be}!"; +1 +EOE + or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; + print "ok 3\n"; +} + +# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt +$encoded_be = "\320\261"; +$encoded_alpha = "\316\261"; +$encoded_bet = "\327\221"; +{ + use charnames ':full'; + + print "not " unless "\N{CYRILLIC SMALL LETTER BE}" eq $encoded_be; + print "ok 4\n"; + + use charnames qw(cyrillic greek :short); + + print "not " unless "\N{be},\N{alpha},\N{hebrew:bet}" + eq "$encoded_be,$encoded_alpha,$encoded_bet"; + print "ok 5\n"; +} + +{ + use charnames ':full'; + print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}"; + print "ok 6\n"; + print "not " unless length("\x{263a}") == 1; + print "ok 7\n"; + print "not " unless length("\N{WHITE SMILING FACE}") == 1; + print "ok 8\n"; + print "not " unless sprintf("%vx", "\x{263a}") eq "263a"; + print "ok 9\n"; + print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"; + print "ok 10\n"; + print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a"; + print "ok 11\n"; + print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; + print "ok 12\n"; +} diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t index b5426ca..7603575 100755 --- a/contrib/perl5/t/lib/checktree.t +++ b/contrib/perl5/t/lib/checktree.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index c073f50..a636ff0 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::Complex; @@ -73,6 +73,7 @@ push(@script, <<'EOT'); my $z = cplx( 1, 1); $z->Re(2); $z->Im(3); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless Re($z) == 2 and Im($z) == 3; EOT push(@script, qq(print "ok $test\\n"}\n)); @@ -82,6 +83,7 @@ push(@script, <<'EOT'); { my $z = cplx( 1, 1); $z->abs(3 * sqrt(2)); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and (arg($z) - pi / 4 ) < $eps and (Re($z) - 3 ) < $eps and @@ -94,6 +96,7 @@ push(@script, <<'EOT'); { my $z = cplx( 1, 1); $z->arg(-3 / 4 * pi); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and (abs($z) - sqrt(2) ) < $eps and (Re($z) + 1 ) < $eps and @@ -120,10 +123,11 @@ push(@script, $constants); sub test_dbz { for my $op (@_) { $test++; - push(@script, <<EOT); -eval '$op'; -print 'not ' unless (\$@ =~ /Division by zero/); + eval '$op'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op divbyzero? \$bad...\n"; + print 'not ' unless (\$@ =~ /Division by zero/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -134,10 +138,11 @@ EOT sub test_loz { for my $op (@_) { $test++; - push(@script, <<EOT); -eval '$op'; -print 'not ' unless (\$@ =~ /Logarithm of zero/); + eval '$op'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op logofzero? \$bad...\n"; + print 'not ' unless (\$@ =~ /Logarithm of zero/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -178,10 +183,11 @@ test_loz( sub test_broot { for my $op (@_) { $test++; - push(@script, <<EOT); -eval 'root(2, $op)'; -print 'not ' unless (\$@ =~ /root must be/); + eval 'root(2, $op)'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op badroot? \$bad...\n"; + print 'not ' unless (\$@ =~ /root must be/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -189,6 +195,99 @@ EOT test_broot(qw(-3 -2.1 0 0.99)); +sub test_display_format { + push @script, <<EOS; + my \$j = (root(1,3))[1]; + + \$j->display_format('polar'); +EOS + + $test++; + push @script, <<EOS; + print "# display_format polar?\n"; + print "not " unless \$j->display_format eq 'polar'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "[1,2pi/3]"; + print "ok $test\n"; + + my %display_format; + + %display_format = \$j->display_format; +EOS + + $test++; + push @script, <<EOS; + print "# display_format{style} polar?\n"; + print "not " unless \$display_format{style} eq 'polar'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# keys %display_format == 2?\n"; + print "not " unless keys %display_format == 2; + print "ok $test\n"; + + \$j->display_format('style' => 'cartesian', 'format' => '%.5f'); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "-0.50000+0.86603i"; + print "ok $test\n"; + + %display_format = \$j->display_format; +EOS + + $test++; + push @script, <<EOS; + print "# display_format{format} %.5f?\n"; + print "not " unless \$display_format{format} eq '%.5f'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# keys %display_format == 3?\n"; + print "not " unless keys %display_format == 3; + print "ok $test\n"; + + \$j->display_format('format' => undef); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "ok $test\n"; + + \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/; + print "ok $test\n"; + + \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); +EOS + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; + print "ok $test\n"; +EOS +} + +test_display_format(); + print "1..$test\n"; eval join '', @script; die $@ if $@; @@ -294,7 +393,7 @@ sub value { sub check { my ($test, $try, $got, $expected, @z) = @_; -# print "# @_\n"; + print "# @_\n"; if ("$got" eq "$expected" || diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t index bf739c8..b13e50ea 100755 --- a/contrib/perl5/t/lib/db-btree.t +++ b/contrib/perl5/t/lib/db-btree.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..102\n"; +print "1..155\n"; sub ok { @@ -38,7 +38,53 @@ sub lexical return @a - @b ; } -$Dfile = "dbbtree.tmp"; +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + wantarray ? @result : join("", @result) ; +} + +sub docat_del +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + unlink $file ; + wantarray ? @result : join("", @result) ; +} + + +$db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; + +my $Dfile = "dbbtree.tmp"; unlink $Dfile; umask(0); @@ -134,7 +180,6 @@ delete $h{'goner2'}; undef $X ; untie(%h); - # tie to the same file again ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; @@ -609,4 +654,567 @@ EOM } +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(104, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(106, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(107, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(108, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(109, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(112, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(113, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(114, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $h{"fred"} eq "joe"); + ok(116, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(117, $db->FIRSTKEY() eq "fred") ; + ok(118, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $h{"fred"} eq "joe"); + ok(121, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(122, $db->FIRSTKEY() eq "fred") ; + ok(123, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(125, $result{"store key"} eq "store key - 1: [fred]"); + ok(126, $result{"store value"} eq "store value - 1: [joe]"); + ok(127, ! defined $result{"fetch key"} ); + ok(128, ! defined $result{"fetch value"} ); + ok(129, $_ eq "original") ; + + ok(130, $db->FIRSTKEY() eq "fred") ; + ok(131, $result{"store key"} eq "store key - 1: [fred]"); + ok(132, $result{"store value"} eq "store value - 1: [joe]"); + ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(134, ! defined $result{"fetch value"} ); + ok(135, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(137, $result{"store value"} eq "store value - 2: [joe john]"); + ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(139, ! defined $result{"fetch value"} ); + ok(140, $_ eq "original") ; + + ok(141, $h{"fred"} eq "joe"); + ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(143, $result{"store value"} eq "store value - 2: [joe john]"); + ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(146, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(149, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(153, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(154, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(155, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t index e748472..c52d8ae 100755 --- a/contrib/perl5/t/lib/db-hash.t +++ b/contrib/perl5/t/lib/db-hash.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..62\n"; +print "1..109\n"; sub ok { @@ -23,7 +23,40 @@ sub ok print "ok $no\n" ; } -$Dfile = "dbhash.tmp"; +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + +my $Dfile = "dbhash.tmp"; unlink $Dfile; umask(0); @@ -164,6 +197,8 @@ 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) ; @@ -413,4 +448,238 @@ EOM unlink "SubDB.pm", "dbhash.tmp" ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(67, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(68, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(69, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(70, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(73, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(74, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(75, $h{"fred"} eq "joe"); + ok(76, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(77, $db->FIRSTKEY() eq "fred") ; + ok(78, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(79, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(80, $h{"fred"} eq "joe"); + ok(81, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(82, $db->FIRSTKEY() eq "fred") ; + ok(83, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(85, $result{"store key"} eq "store key - 1: [fred]"); + ok(86, $result{"store value"} eq "store value - 1: [joe]"); + ok(87, ! defined $result{"fetch key"} ); + ok(88, ! defined $result{"fetch value"} ); + ok(89, $_ eq "original") ; + + ok(90, $db->FIRSTKEY() eq "fred") ; + ok(91, $result{"store key"} eq "store key - 1: [fred]"); + ok(92, $result{"store value"} eq "store value - 1: [joe]"); + ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(94, ! defined $result{"fetch value"} ); + ok(95, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(97, $result{"store value"} eq "store value - 2: [joe john]"); + ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(99, ! defined $result{"fetch value"} ); + ok(100, $_ eq "original") ; + + ok(101, $h{"fred"} eq "joe"); + ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(103, $result{"store value"} eq "store value - 2: [joe john]"); + ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(106, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(109, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index da703c9..276f38b 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -38,6 +38,49 @@ sub ok return $result ; } +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + sub bad_one { print STDERR <<EOM unless $bad_ones++ ; @@ -46,7 +89,7 @@ sub bad_one # 53 and 55. # # You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). +# broken functionality (recno databases with a modified bval). # Otherwise you'll have to upgrade your DB library. # # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the @@ -56,7 +99,7 @@ sub bad_one EOM } -print "1..78\n"; +print "1..126\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -209,16 +252,6 @@ untie(@h); unlink $Dfile; -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - { # Check bval defaults to \n @@ -452,4 +485,355 @@ EOM } +{ + # DBM Filter tests + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(80, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(81, $h[0] eq "joe"); + # fk sk fv sv + ok(82, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(83, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(84, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(85, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(87, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(88, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(89, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(90, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(91, $h[0] eq "joe"); + ok(92, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(93, $db->FIRSTKEY() == 0) ; + ok(94, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(95, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(96, $h[0] eq "joe"); + ok(97, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(98, $db->FIRSTKEY() == 0) ; + ok(99, checkOutput( "", "", "", "")) ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(101, $result{"store key"} eq "store key - 1: [0]"); + ok(102, $result{"store value"} eq "store value - 1: [joe]"); + ok(103, ! defined $result{"fetch key"} ); + ok(104, ! defined $result{"fetch value"} ); + ok(105, $_ eq "original") ; + + ok(106, $db->FIRSTKEY() == 0 ) ; + ok(107, $result{"store key"} eq "store key - 1: [0]"); + ok(108, $result{"store value"} eq "store value - 1: [joe]"); + ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(110, ! defined $result{"fetch value"} ); + ok(111, $_ eq "original") ; + + $h[7] = "john" ; + ok(112, $result{"store key"} eq "store key - 2: [0 7]"); + ok(113, $result{"store value"} eq "store value - 2: [joe john]"); + ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(115, ! defined $result{"fetch value"} ); + ok(116, $_ eq "original") ; + + ok(117, $h[0] eq "joe"); + ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(119, $result{"store value"} eq "store value - 2: [joe john]"); + ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(122, $_ eq "original") ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_store_key (sub { $_ = $h[0] }) ; + + eval '$h[1] = 1234' ; + ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie @h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(125, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(126, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t index aa7be35..a8683c7 100755 --- a/contrib/perl5/t/lib/dirhand.t +++ b/contrib/perl5/t/lib/dirhand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (not $Config{'d_readdir'}) { print "1..0\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t index 577d4ea..ea537bf 100755 --- a/contrib/perl5/t/lib/dosglob.t +++ b/contrib/perl5/t/lib/dosglob.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..10\n"; diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t new file mode 100755 index 0000000..4d6f782 --- /dev/null +++ b/contrib/perl5/t/lib/dprof.t @@ -0,0 +1,80 @@ +#!perl + +BEGIN { + chdir( 't' ) if -d 't'; + unshift @INC, '../lib'; +} + +END { + unlink 'tmon.out', 'err'; +} + +use Benchmark qw( timediff timestr ); +use Getopt::Std 'getopts'; +use Config '%Config'; +getopts('vI:p:'); + +# -v Verbose +# -I Add to @INC +# -p Name of perl binary + +@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>; # glob-sort, for OS/2 + +$path_sep = $Config{path_sep} || ':'; +$perl5lib = $opt_I || join( $path_sep, @INC ); +$perl = $opt_p || $^X; + +if( $opt_v ){ + print "tests: @tests\n"; + print "perl: $perl\n"; + print "perl5lib: $perl5lib\n"; +} +if( $perl =~ m|^\./| ){ + # turn ./perl into ../perl, because of chdir(t) above. + $perl = ".$perl"; +} +if( ! -f $perl ){ die "Where's Perl?" } + +sub profile { + my $test = shift; + my @results; + local $ENV{PERL5LIB} = $perl5lib; + my $opt_d = '-d:DProf'; + + my $t_start = new Benchmark; + open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + @results = <R>; + close R; + my $t_total = timediff( new Benchmark, $t_start ); + + if( $opt_v ){ + print "\n"; + print @results + } + + print timestr( $t_total, 'nop' ), "\n"; +} + + +sub verify { + my $test = shift; + + system $perl, '-I../lib', '-I./lib/dprof', $test, + $opt_v?'-v':'', '-p', $perl; +} + + +$| = 1; +print "1..18\n"; +while( @tests ){ + $test = shift @tests; + if( $test =~ /_t$/i ){ + print "# $test" . '.' x (20 - length $test); + profile $test; + } + else{ + verify $test; + } +} + +unlink("tmon.out"); diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm new file mode 100644 index 0000000..7e34da5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/V.pm @@ -0,0 +1,59 @@ +package V; + +use Getopt::Std 'getopts'; +getopts('vp:d:'); + +require Exporter; +@ISA = 'Exporter'; + +@EXPORT = qw( dprofpp $opt_v $results $expected report @results ); +@EXPORT_OK = qw( notok ok $num ); + +$num = 0; +$results = $expected = ''; +$perl = $opt_p || $^X; +$dpp = $opt_d || '../utils/dprofpp'; + +print "\nperl: $perl\n" if $opt_v; +if( ! -f $perl ){ die "Where's Perl?" } +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"; + @results = <D>; + close D; + + open( D, "<err" ) || warn "$0: Can't open: $!\n"; + @err = <D>; + close D; + push( @results, @err ) if @err; + + $results = qq{@results}; + # ignore Loader (Dyna/Auto etc), leave newline + $results =~ s/^\w+Loader::import//; + $results =~ s/\n /\n/gm; + $results; +} + +sub report { + $num = shift; + my $sub = shift; + my $x; + + $x = &$sub; + $x ? &ok : ¬ok; +} + +sub ok { + print "ok $num\n"; +} + +sub notok { + print "not ok $num\n"; + print "\nResult\n{$results}\n"; + print "Expected\n{$expected}\n"; +} + +1; diff --git a/contrib/perl5/t/lib/dprof/test1_t b/contrib/perl5/t/lib/dprof/test1_t new file mode 100644 index 0000000..d504cd5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test1_t @@ -0,0 +1,18 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test1_v b/contrib/perl5/t/lib/dprof/test1_v new file mode 100644 index 0000000..542a503 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test1_v @@ -0,0 +1,24 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +report 3, sub { $expected eq $results }; + +dprofpp('-tF'); +report 4, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test2_t b/contrib/perl5/t/lib/dprof/test2_t new file mode 100644 index 0000000..edc46c5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test2_t @@ -0,0 +1,21 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test2_v b/contrib/perl5/t/lib/dprof/test2_v new file mode 100644 index 0000000..8b775b3 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test2_v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 5, sub { $expected eq $results }; + +dprofpp('-TF'); +report 6, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 7, sub { $expected eq $results }; + +dprofpp('-tF'); +report 8, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test3_t b/contrib/perl5/t/lib/dprof/test3_t new file mode 100644 index 0000000..a5327f4 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test3_t @@ -0,0 +1,19 @@ +sub foo { + print "in sub foo\n"; + exit(0); + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test3_v b/contrib/perl5/t/lib/dprof/test3_v new file mode 100644 index 0000000..df7543e --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test3_v @@ -0,0 +1,29 @@ +# perl + +use V; + +dprofpp( '-T' ); +$e1 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 9, sub { $expected eq $results }; + +dprofpp('-TF'); +$e2 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 10, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = $e1; +report 11, sub { 1 }; + +dprofpp('-tF'); +$expected = $e2; +report 12, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test4_t b/contrib/perl5/t/lib/dprof/test4_t new file mode 100644 index 0000000..7299682 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test4_t @@ -0,0 +1,24 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); + +eval { fork }; + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test4_v b/contrib/perl5/t/lib/dprof/test4_v new file mode 100644 index 0000000..d9677ff --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test4_v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 13, sub { $expected eq $results }; + +dprofpp('-TF'); +report 14, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 15, sub { $expected eq $results }; + +dprofpp('-tF'); +report 16, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test5_t b/contrib/perl5/t/lib/dprof/test5_t new file mode 100644 index 0000000..0b11137 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test5_t @@ -0,0 +1,25 @@ +# Test that dprof doesn't break +# &bar; used as &bar(@_); + +sub foo1 { + print "in foo1(@_)\n"; + bar(@_); +} +sub foo2 { + print "in foo2(@_)\n"; + &bar; +} +sub bar { + print "in bar(@_)\n"; + if( @_ > 0 ){ + &yeppers; + } +} +sub yeppers { + print "rest easy\n"; +} + + +&foo1( A ); +&foo2( B ); + diff --git a/contrib/perl5/t/lib/dprof/test5_v b/contrib/perl5/t/lib/dprof/test5_v new file mode 100644 index 0000000..9e9298c --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test5_v @@ -0,0 +1,15 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::foo1 + main::bar + main::yeppers +main::foo2 + main::bar + main::yeppers +}; +report 17, sub { $expected eq $results }; + diff --git a/contrib/perl5/t/lib/dprof/test6_t b/contrib/perl5/t/lib/dprof/test6_t new file mode 100644 index 0000000..7b8bf4a --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test6_t @@ -0,0 +1,29 @@ +sub foo { + my $x; + my $y; + print "in sub foo\n"; + for( $x = 1; $x < 100; ++$x ){ + bar(); + for( $y = 1; $y < 100; ++$y ){ + } + } +} + +sub bar { + my $x; + print "in sub bar\n"; + for( $x = 1; $x < 100; ++$x ){ + } + die "bar exiting"; +} + +sub baz { + print "in sub baz\n"; + eval { bar(); }; + eval { foo(); }; +} + +eval { bar(); }; +baz(); +eval { foo(); }; + diff --git a/contrib/perl5/t/lib/dprof/test6_v b/contrib/perl5/t/lib/dprof/test6_v new file mode 100644 index 0000000..2f651ea --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test6_v @@ -0,0 +1,16 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 18, sub { $expected eq $results }; + diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t index db4a5d9..8c095e5 100755 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use Data::Dumper; diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 8c8dc40..3167535 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use Data::Dumper; @@ -22,6 +22,16 @@ sub TEST { my $string = shift; my $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # these data need massaging with non ascii character sets + # because of hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); @@ -31,17 +41,26 @@ sub TEST { $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # here too there are hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); } if (defined &Data::Dumper::Dumpxs) { print "### XS extension loaded, will run XS tests\n"; - $TMAX = 162; $XS = 1; + $TMAX = 186; $XS = 1; } else { print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 81; $XS = 0; + $TMAX = 93; $XS = 0; } print "1..$TMAX\n"; @@ -236,20 +255,11 @@ EOT ############# 43 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #$VAR1 = { # "abc\0'\efg" => "mno\0" #}; EOT -} -else { -$WANT = <<'EOT'; -#$VAR1 = { -# "\201\202\203\340\360'\340\205\206\207" => "\224\225\226\340\360" -#}; -EOT -} $foo = { "abc\000\'\efg" => "mno\000" }; { @@ -291,11 +301,11 @@ EOT # #0 # 10, # #1 -# '', +# do{my $o}, # #2 # { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} # } @@ -321,10 +331,10 @@ EOT #*::foo = \5; #*::foo = [ # 10, -# '', +# do{my $o}, # { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} # } @@ -354,7 +364,7 @@ EOT #*::foo = \@bar; #*::foo = { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} #}; @@ -381,7 +391,7 @@ EOT #*::foo = $bar; #*::foo = { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} #}; @@ -455,7 +465,6 @@ EOT ############# 85 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', @@ -468,21 +477,6 @@ if (!$Is_ebcdic) { #); #%mutts = %kennels; EOT -} -else { - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT -} TEST q( $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], @@ -510,7 +504,6 @@ EOT ############# 97 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', @@ -523,21 +516,7 @@ if (!$Is_ebcdic) { #); #%mutts = %kennels; EOT -} -else { - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT -} + TEST q($d->Reset; $d->Dump); if ($XS) { @@ -546,8 +525,7 @@ EOT ############# 103 ## -if (!$Is_ebcdic) { - $WANT = <<'EOT'; + $WANT = <<'EOT'; #@dogs = ( # 'Fido', # 'Wags', @@ -559,21 +537,6 @@ if (!$Is_ebcdic) { #%kennels = %{$dogs[2]}; #%mutts = %{$dogs[2]}; EOT -} -else { - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \$dogs[1], -# First => \$dogs[0] -# } -#); -#%kennels = %{$dogs[2]}; -#%mutts = %{$dogs[2]}; -EOT -} TEST q( $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], @@ -597,7 +560,6 @@ EOT ############# 115 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #@dogs = ( # 'Fido', @@ -612,23 +574,6 @@ if (!$Is_ebcdic) { # Second => \'Wags' #); EOT -} -else { - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \'Wags', -# First => \'Fido' -# } -#); -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -EOT -} TEST q( $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); @@ -695,7 +640,7 @@ TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) $WANT = <<'EOT'; #@a = ( # undef, -# '' +# do{my $o} #); #$a[1] = \$a[0]; EOT @@ -732,7 +677,7 @@ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) # { # a => \[ # { -# c => '' +# c => do{my $o} # }, # { # d => \[] @@ -778,3 +723,79 @@ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) if $XS; } + +{ + $f = "pearl"; + $e = [ $f ]; + $d = { 'e' => $e }; + $c = [ $d ]; + $b = { 'c' => $c }; + $a = { 'b' => $b }; + +############# 163 +## + $WANT = <<'EOT'; +#$a = { +# b => { +# c => [ +# { +# e => 'ARRAY(0xdeadbeef)' +# } +# ] +# } +#}; +#$b = $a->{b}; +#$c = $a->{b}{c}; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;) + if $XS; + +############# 169 +## + $WANT = <<'EOT'; +#$a = { +# b => 'HASH(0xdeadbeef)' +#}; +#$b = $a->{b}; +#$c = [ +# 'HASH(0xdeadbeef)' +#]; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;) + if $XS; +} + +{ + $a = \$a; + $b = [$a]; + +############# 175 +## + $WANT = <<'EOT'; +#$b = [ +# \$b->[0] +#]; +EOT + +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) + if $XS; + +############# 181 +## + $WANT = <<'EOT'; +#$b = [ +# \do{my $o} +#]; +#${$b->[0]} = $b->[0]; +EOT + + +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) + if $XS; +} diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t index 9691229..dba68db 100755 --- a/contrib/perl5/t/lib/english.t +++ b/contrib/perl5/t/lib/english.t @@ -2,10 +2,10 @@ print "1..16\n"; -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } use English; use Config; -my $threads = $Config{'usethreads'} || 0; +my $threads = $Config{'use5005threads'} || 0; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t new file mode 100755 index 0000000..d90d892 --- /dev/null +++ b/contrib/perl5/t/lib/env-array.t @@ -0,0 +1,100 @@ +#!./perl + +$| = 1; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +if ($^O eq 'VMS') { + print "1..11\n"; + foreach (1..11) { print "ok $_ # skipped for VMS\n"; } + exit 0; +} + +use Env qw(@FOO); +use vars qw(@BAR); + +sub array_equal +{ + my ($a, $b) = @_; + return 0 unless scalar(@$a) == scalar(@$b); + for my $i (0..scalar(@$a) - 1) { + return 0 unless $a->[$i] eq $b->[$i]; + } + return 1; +} + +sub test +{ + my ($desc, $code) = @_; + + &$code; + + print "# $desc...\n"; + print "# FOO = (", join(", ", @FOO), ")\n"; + print "# BAR = (", join(", ", @BAR), ")\n"; + + if (defined $check) { print "not " unless &$check; } + else { print "not " unless array_equal(\@FOO, \@BAR); } + + print "ok ", ++$i, "\n"; +} + +print "1..11\n"; + +test "Assignment", sub { + @FOO = qw(a B c); + @BAR = qw(a B c); +}; + +test "Storing", sub { + $FOO[1] = 'b'; + $BAR[1] = 'b'; +}; + +test "Truncation", sub { + $#FOO = 0; + $#BAR = 0; +}; + +test "Push", sub { + push @FOO, 'b', 'c'; + push @BAR, 'b', 'c'; +}; + +test "Pop", sub { + pop @FOO; + pop @BAR; +}; + +test "Shift", sub { + shift @FOO; + shift @BAR; +}; + +test "Push", sub { + push @FOO, 'c'; + push @BAR, 'c'; +}; + +test "Unshift", sub { + unshift @FOO, 'a'; + unshift @BAR, 'a'; +}; + +test "Reverse", sub { + @FOO = reverse @FOO; + @BAR = reverse @BAR; +}; + +test "Sort", sub { + @FOO = sort @FOO; + @BAR = sort @BAR; +}; + +test "Splice", sub { + splice @FOO, 1, 1, 'B'; + splice @BAR, 1, 1, 'B'; +}; diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t index 5a82207..2573164 100755 --- a/contrib/perl5/t/lib/env.t +++ b/contrib/perl5/t/lib/env.t @@ -2,17 +2,24 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } BEGIN { $ENV{FOO} = "foo"; + $ENV{BAR} = "bar"; } -use Env qw(FOO); +use Env qw(FOO $BAR); $FOO .= "/bar"; +$BAR .= "/baz"; + +print "1..2\n"; -print "1..1\n"; print "not " if $FOO ne 'foo/bar'; print "ok 1\n"; + +print "not " if $BAR ne 'bar/baz'; +print "ok 2\n"; + diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t index 361723f..6320f6b 100755 --- a/contrib/perl5/t/lib/errno.t +++ b/contrib/perl5/t/lib/errno.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t index fb3757f..4013fbd 100755 --- a/contrib/perl5/t/lib/fatal.t +++ b/contrib/perl5/t/lib/fatal.t @@ -3,11 +3,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; - print "1..9\n"; + print "1..15\n"; } use strict; -use Fatal qw(open); +use Fatal qw(open close :void opendir); my $i = 1; eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; @@ -20,8 +20,17 @@ for ('$foo', "'$foo'", "*$foo", "\\*$foo") { print "not " if $@; print "ok $i\n"; ++$i; - print "not " unless scalar(<FOO>) =~ m|^#!./perl|; + print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|; + print "ok $i\n"; ++$i; + eval qq{ close FOO }; print "not " if $@; print "ok $i\n"; ++$i; - close FOO; } + +eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " unless $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; + +eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " if $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t index 139e469..7709ee5 100755 --- a/contrib/perl5/t/lib/fields.t +++ b/contrib/perl5/t/lib/fields.t @@ -4,7 +4,7 @@ my $w; BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; $SIG{__WARN__} = sub { if ($_[0] =~ /^Hides field 'b1' in base class/) { $w++; @@ -15,6 +15,7 @@ BEGIN { } use strict; +use warnings; use vars qw($DEBUG); package B1; @@ -56,10 +57,17 @@ package Foo::Bar::Baz; use base 'Foo::Bar'; use fields qw(foo bar baz); +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + package main; -sub fstr -{ +sub fstr { my $h = shift; my @tmp; for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { @@ -82,7 +90,7 @@ my %expect = ( 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', ); -print "1..", int(keys %expect)+3, "\n"; +print "1..", int(keys %expect)+13, "\n"; my $testno = 0; while (my($class, $exp) = each %expect) { no strict 'refs'; @@ -106,7 +114,59 @@ print "ok ", ++$testno, "\n"; # We should get compile time failures field name typos eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such field "notthere"/; +print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; +print "ok ", ++$testno, "\n"; + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +print "not " unless "@$obj1[1,2]" eq "17 29"; +print "ok ", ++$testno, "\n"; +@$obj1[1,2] = (44,28); +print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; +print "ok ", ++$testno, "\n"; + +my $ph = fields::phash(a => 1, b => 2, c => 3); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1, 2, 3]); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1]); +print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; +print "ok ", ++$testno, "\n"; + +eval '$ph = fields::phash("odd")'; +print "not " unless $@ && $@ =~ /^Odd number of/; print "ok ", ++$testno, "\n"; #fields::_dump(); + +# check if fields autovivify +{ + package Foo; + use fields qw(foo bar); + sub new { bless [], $_[0]; } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t index a97fdd5..019f374 100755 --- a/contrib/perl5/t/lib/filecache.t +++ b/contrib/perl5/t/lib/filecache.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t index 329931f..b6fcbea 100755 --- a/contrib/perl5/t/lib/filecopy.t +++ b/contrib/perl5/t/lib/filecopy.t @@ -2,89 +2,108 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..11\n"; - $| = 1; +my @pass = (0,1); +my $tests = 11; +printf "1..%d\n", $tests * scalar(@pass); + use File::Copy; -# First we create a file -open(F, ">file-$$") or die; -binmode F; # for DOSISH platforms, because test 3 copies to stdout -print F "ok 3\n"; -close F; - -copy "file-$$", "copy-$$"; - -open(F, "copy-$$") or die; -$foo = <F>; -close(F); - -print "not " if -s "file-$$" != -s "copy-$$"; -print "ok 1\n"; - -print "not " unless $foo eq "ok 3\n"; -print "ok 2\n"; - -binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode -copy "copy-$$", \*STDOUT; -unlink "copy-$$" or die "unlink: $!"; - -open(F,"file-$$"); -copy(*F, "copy-$$"); -open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 4\n"; -unlink "copy-$$" or die "unlink: $!"; -open(F,"file-$$"); -copy(\*F, "copy-$$"); -close(F) or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; -print "not " unless $foo eq "ok 3\n"; -print "ok 5\n"; -unlink "copy-$$" or die "unlink: $!"; - -require IO::File; -$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 6\n"; -unlink "copy-$$" or die "unlink: $!"; -require FileHandle; -my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 7\n"; -unlink "file-$$" or die "unlink: $!"; - -print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); -print "# target disappeared.\nnot " if not -e "copy-$$"; -print "ok 8\n"; - -move "copy-$$", "file-$$" or print "# move did not succeed.\n"; -print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; -open(R, "file-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 9\n"; - -copy "file-$$", "lib"; -open(R, "lib/file-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 10\n"; -unlink "lib/file-$$" or die "unlink: $!"; - -move "file-$$", "lib"; -open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; -print "ok 11\n"; -unlink "lib/file-$$" or die "unlink: $!"; +for my $pass (@pass) { + + require File::Copy; + + my $loopconst = $pass*$tests; + + # First we create a file + open(F, ">file-$$") or die; + binmode F; # for DOSISH platforms, because test 3 copies to stdout + printf F "ok %d\n", 3 + $loopconst; + close F; + + copy "file-$$", "copy-$$"; + + open(F, "copy-$$") or die; + $foo = <F>; + close(F); + + print "not " if -s "file-$$" != -s "copy-$$"; + printf "ok %d\n", 1 + $loopconst; + + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 2+$loopconst; + + binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode + copy "copy-$$", \*STDOUT; + unlink "copy-$$" or die "unlink: $!"; + + open(F,"file-$$"); + copy(*F, "copy-$$"); + open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 4+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + open(F,"file-$$"); + copy(\*F, "copy-$$"); + close(F) or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 5+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + + require IO::File; + $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 6+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + require FileHandle; + my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 7+$loopconst; + unlink "file-$$" or die "unlink: $!"; + + print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); + print "# target disappeared.\nnot " if not -e "copy-$$"; + printf "ok %d\n", 8+$loopconst; + + move "copy-$$", "file-$$" or print "# move did not succeed.\n"; + print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; + open(R, "file-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 9+$loopconst; + + copy "file-$$", "lib"; + open(R, "lib/file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + move "file-$$", "lib"; + open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 11+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + # warn sprintf "INC->".$INC{"File/Copy.pm"}; + delete $INC{"File/Copy.pm"}; + +} + +END { + 1 while unlink "file-$$"; + 1 while unlink "lib/file-$$"; +} diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t index cd2e977..e9a2916 100755 --- a/contrib/perl5/t/lib/filefind.t +++ b/contrib/perl5/t/lib/filefind.t @@ -1,14 +1,168 @@ -#!./perl +####!./perl + + +my %Expect; +my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..2\n"; +if ( $symlink_exists ) { print "1..117\n"; } +else { print "1..61\n"; } use File::Find; -# hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); + + +my $case = 2; + +END { + unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', + 'fa/fab/fab_ord','fa/fab/faba/faba_ord','fb/fb_ord','fb/fba/fba_ord'; + rmdir 'fa/faa'; + rmdir 'fa/fab/faba'; + rmdir 'fa/fab'; + rmdir 'fa'; + rmdir 'fb/fba'; + rmdir 'fb'; + chdir '..'; + rmdir 'for_find'; +} + +sub Check($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n"; } +} + +sub CheckDie($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { + CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { + CheckDie( mkdir($_[0],$_[1]) ); +} + +sub wanted { + print "# '$_' => 1\n"; + s#\.$## if ($^O eq 'VMS' && $_ ne '.'); + Check( $Expect{$_} ); + delete $Expect{$_}; + $File::Find::prune=1 if $_ eq 'faba'; +} + +sub dn_wanted { + my $n = $File::Find::name; + $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); + print "# '$n' => 1\n"; + my $i = rindex($n,'/'); + my $OK = exists($Expect{$n}); + if ( $OK ) { + $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0; + } + Check($OK); + delete $Expect{$n}; +} + +sub d_wanted { + print "# '$_' => 1\n"; + s#\.$## if ($^O eq 'VMS' && $_ ne '.'); + my $i = rindex($_,'/'); + my $OK = exists($Expect{$_}); + if ( $OK ) { + $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0; + } + Check($OK); + delete $Expect{$_}; +} + +MkDir( 'for_find',0770 ); +CheckDie(chdir(for_find)); +MkDir( 'fa',0770 ); +MkDir( 'fb',0770 ); +touch('fb/fb_ord'); +MkDir( 'fb/fba',0770 ); +touch('fb/fba/fba_ord'); +CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; +touch('fa/fa_ord'); + +MkDir( 'fa/faa',0770 ); +touch('fa/faa/faa_ord'); +MkDir( 'fa/fab',0770 ); +touch('fa/fab/fab_ord'); +MkDir( 'fa/fab/faba',0770 ); +touch('fa/fab/faba/faba_ord'); + +%Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, + 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); +delete $Expect{'fsl'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, },'fa' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, + 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); +delete $Expect{'fa/fsl'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); + +Check( scalar(keys %Expect) == 0 ); + +%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, + './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, + './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, + './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); +delete $Expect{'./fa/fsl'} unless $symlink_exists; +File::Find::finddepth( {wanted => \&dn_wanted },'.' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, + './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, + './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, + './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); +delete $Expect{'./fa/fsl'} unless $symlink_exists; +File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); +Check( scalar(keys %Expect) == 0 ); + +if ( $symlink_exists ) { + %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, + 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, + 'faa_ord' => 1); + + File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + + File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + + File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); +} + +print "# of cases: $case\n"; diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t new file mode 100755 index 0000000..46a1e35 --- /dev/null +++ b/contrib/perl5/t/lib/filefunc.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + $^O = ''; + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..1\n"; + +use File::Spec::Functions; + +if (catfile('a','b','c') eq 'a/b/c') { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t index b8ec95f..22cff0e 100755 --- a/contrib/perl5/t/lib/filehand.t +++ b/contrib/perl5/t/lib/filehand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; @@ -72,7 +72,8 @@ if ($^O eq 'dos') ($rd,$wr) = FileHandle::pipe; -if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32') { +if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $Config{d_fork} ne 'define') { $wr->autoflush; $wr->printf("ok %d\n",11); print $rd->getline; diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t index c3bf4a4..5628d0c 100755 --- a/contrib/perl5/t/lib/filepath.t +++ b/contrib/perl5/t/lib/filepath.t @@ -2,14 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use File::Path; use strict; my $count = 0; -$^W = 1; +use warnings; print "1..4\n"; diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t index ca22d3e..da52ec5 100755 --- a/contrib/perl5/t/lib/filespec.t +++ b/contrib/perl5/t/lib/filespec.t @@ -3,41 +3,377 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..4\n"; +# Each element in this array is a single test. Storing them this way makes +# maintenance easy, and should be OK since perl should be pretty functional +# before these tests are run. -use File::Spec; +@tests = ( +# Function Expected +[ "Unix->catfile('a','b','c')", 'a/b/c' ], +[ "Unix->splitpath('file')", ',,file' ], +[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], +[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], +[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], +[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], +[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], +[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], +[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], +[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], -if (File::Spec->catfile('a','b','c') eq 'a/b/c') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} +[ "Unix->catpath('','','file')", 'file' ], +[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], +[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], +[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], +[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], +[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], +[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], +[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], +[ "Unix->catpath('','/././d1/','')", '/././d1/' ], +[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], +[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], -use File::Spec::OS2; +[ "Unix->splitdir('')", '' ], +[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], +[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], +[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], +[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], -if (File::Spec::OS2->catfile('a','b','c') eq 'a/b/c') { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} +[ "Unix->catdir()", '' ], +[ "Unix->catdir('/')", '/' ], +[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], +[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], + +[ "Unix->catfile('a','b','c')", 'a/b/c' ], + +[ "Unix->canonpath('')", '' ], +[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Unix->canonpath('/.')", '/.' ], + +[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], +[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ], +[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], + +[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], +[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], +[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], +[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], +[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], +[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], + +[ "Win32->splitpath('file')", ',,file' ], +[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], +[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], +[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], +[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], +[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], +[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], +[ "Win32->splitpath('file',1)", ',file,' ], +[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], + +[ "Win32->catpath('','','file')", 'file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], +[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], +[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], +[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], +[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], +[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], +[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], +[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], +[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], +[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], +[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], + +[ "Win32->splitdir('')", '' ], +[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], +[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], +[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], +[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], + +[ "Win32->catdir()", '' ], +[ "Win32->catdir('')", '\\' ], +[ "Win32->catdir('/')", '\\' ], +[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], +[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], +[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], +[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], +[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], +[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], +[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], +[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], +#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], +[ "Win32->catdir('A:/')", 'A:\\' ], + +[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], + +[ "Win32->canonpath('')", '' ], +[ "Win32->canonpath('a:')", 'A:' ], +[ "Win32->canonpath('A:f')", 'A:f' ], +[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], +[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('////')", '\\\\\\' ], +[ "Win32->canonpath('//')", '\\' ], +[ "Win32->canonpath('/.')", '\\.' ], +[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ], +[ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ], + +[ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], +[ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], +[ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], +#[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ], +[ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ], +[ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ], +[ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ], + +[ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ], +[ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], +[ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], +[ "Win32->rel2abs('../','C:/')", 'C:\\..' ], +[ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ], +[ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], +[ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ], +[ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], +[ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], + +[ "VMS->splitpath('file')", ',,file' ], +[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], + +[ "VMS->catpath('','','file')", 'file' ], +[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], +[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], +[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], +[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], + +[ "VMS->canonpath('')", '' ], +[ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], +[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], +[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], + +[ "VMS->splitdir('')", '' ], +[ "VMS->splitdir('[]')", '' ], +[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], +[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], +[ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ], +[ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ], +[ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], +[ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], + +[ "VMS->catdir('')", '' ], +[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], +[ "VMS->catdir('','-','','d3')", '[-.d3]' ], +[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], +[ "VMS->catdir('[.name]')", '[.name]' ], +[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], + +[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], +[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ], +[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], +[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], +[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], +[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], +[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], +[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], -use File::Spec::Win32; +[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], +[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], +[ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], +[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], +[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], +[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], -if (File::Spec::Win32->catfile('a','b','c') eq 'a\b\c') { - print "ok 3\n"; -} else { - print "not ok 3\n"; +[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], +[ "OS2->catfile('a','b','c')", 'a/b/c' ], + +[ "Mac->splitpath('file')", ',,file' ], +[ "Mac->splitpath(':file')", ',:,file' ], +[ "Mac->splitpath(':d1',1)", ',:d1:,' ], +[ "Mac->splitpath('d1',1)", 'd1:,,' ], +[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], +[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], +[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], +[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], + +[ "Mac->catdir('')", ':' ], +[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], +[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], +[ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], +[ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], +[ "Mac->catdir('','','','d3')", ':::d3:' ], +[ "Mac->catdir(':name')", ':name:' ], +[ "Mac->catdir(':name',':name')", ':name:name:' ], + +[ "Mac->catfile('a','b','c')", 'a:b:c' ], + +[ "Mac->canonpath('')", '' ], +[ "Mac->canonpath(':')", ':' ], +[ "Mac->canonpath('::')", '::' ], +[ "Mac->canonpath('a::')", 'a::' ], +[ "Mac->canonpath(':a::')", ':a::' ], + +[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], +[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], +[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], +[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], +[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], +[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], +[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], + +[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], +[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], +[ "Mac->rel2abs('','t1:t2:t3')", '' ], +[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], +[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], +[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], +) ; + +# Grab all of the plain routines from File::Spec +use File::Spec @File::Spec::EXPORT_OK ; + +require File::Spec::Unix ; +require File::Spec::Win32 ; + +eval { + require VMS::Filespec ; +} ; + +my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; + +if ( $@ ) { + # Not pretty, but it allows testing of things not implemented soley + # on VMS. It might be better to change File::Spec::VMS to do this, + # making it more usable when running on (say) Unix but working with + # VMS paths. + eval qq- + sub File::Spec::VMS::vmsify { die "$skip_exception" } + sub File::Spec::VMS::unixify { die "$skip_exception" } + sub File::Spec::VMS::vmspath { die "$skip_exception" } + - ; + $INC{"VMS/Filespec.pm"} = 1 ; } +require File::Spec::VMS ; + +require File::Spec::OS2 ; +require File::Spec::Mac ; + +print "1..", scalar( @tests ), "\n" ; -use File::Spec::Mac; +my $current_test= 1 ; -if (File::Spec::Mac->catfile('a','b','c') eq 'a:b:c') { - print "ok 4\n"; -} else { - print "not ok 4\n"; +# Test out the class methods +for ( @tests ) { + tryfunc( @$_ ) ; } + + +# +# Tries a named function with the given args and compares the result against +# an expected result. Works with functions that return scalars or arrays. +# +sub tryfunc { + my $function = shift ; + my $expected = shift ; + my $platform = shift ; + + if ($platform && $^O ne $platform) { + print "ok $current_test # skipped: $function\n" ; + ++$current_test ; + return; + } + + $function =~ s#\\#\\\\#g ; + + my $got ; + if ( $function =~ /^[^\$].*->/ ) { + $got = eval( "join( ',', File::Spec::$function )" ) ; + } + else { + $got = eval( "join( ',', $function )" ) ; + } + + if ( $@ ) { + if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) { + chomp $@ ; + print "ok $current_test # skip $function: $@\n" ; + } + else { + chomp $@ ; + print "not ok $current_test # $function: $@\n" ; + } + } + elsif ( !defined( $got ) || $got ne $expected ) { + print "not ok $current_test # $function: got '$got', expected '$expected'\n" ; + } + else { + print "ok $current_test # $function\n" ; + } + ++$current_test ; +} diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t index 3e742f9..f0939e9 100755 --- a/contrib/perl5/t/lib/findbin.t +++ b/contrib/perl5/t/lib/findbin.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t index 2395611..dc4e96e 100755 --- a/contrib/perl5/t/lib/gdbm.t +++ b/contrib/perl5/t/lib/gdbm.t @@ -3,17 +3,17 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bGDBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: GDBM_File was not built\n"; exit 0; } } use GDBM_File; -print "1..20\n"; +print "1..66\n"; unlink <Op.dbmx*>; @@ -206,3 +206,189 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(22, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(24, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(25, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(26, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(27, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(30, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(31, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(32, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $h{"fred"} eq "joe"); + ok(34, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(35, $db->FIRSTKEY() eq "fred") ; + ok(36, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $h{"fred"} eq "joe"); + ok(39, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(40, $db->FIRSTKEY() eq "fred") ; + ok(41, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, $result{"fetch value"} eq ""); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t index fb70f10..0354627 100755 --- a/contrib/perl5/t/lib/getopt.t +++ b/contrib/perl5/t/lib/getopt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t new file mode 100755 index 0000000..4728083 --- /dev/null +++ b/contrib/perl5/t/lib/glob-basic.t @@ -0,0 +1,119 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..9\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob ':glob'; +use Cwd (); +$loaded = 1; +print "ok 1\n"; + +sub array { + return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; +} + +# look for the contents of the current directory +$ENV{PATH} = "/bin"; +delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; +@correct = (); +if (opendir(D, ".")) { + @correct = grep { !/^\.\.?$/ } sort readdir(D); + closedir D; +} +@a = File::Glob::glob("*", 0); +@a = sort @a; +if ("@a" ne "@correct" || GLOB_ERROR) { + print "# |@a| ne |@correct|\nnot "; +} +print "ok 2\n"; + +# look up the user's home directory +# should return a list with one item, and not set ERROR +if ($^O ne 'MSWin32' || $^O ne 'VMS') { + eval { + ($name, $home) = (getpwuid($>))[0,7]; + 1; + } and do { + @a = File::Glob::glob("~$name", GLOB_TILDE); + if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { + print "not "; + } + }; +} +print "ok 3\n"; + +# check backslashing +# should return a list with one item, and not set ERROR +@a = File::Glob::glob('TEST', GLOB_QUOTE); +if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { + local $/ = "]["; + print "# [@a]\n"; + print "not "; +} +print "ok 4\n"; + +# check nonexistent checks +# should return an empty list +# XXX since errfunc is NULL on win32, this test is not valid there +@a = File::Glob::glob("asdfasdf", 0); +if ($^O ne 'MSWin32' and scalar @a != 0) { + print "# |@a|\nnot "; +} +print "ok 5\n"; + +# check bad protections +# should return an empty list, and set ERROR +if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' + or $^O eq 'cygwin' or Cwd::cwd() =~ m#^/afs#s or not $>) +{ + print "ok 6 # skipped\n"; +} +else { + $dir = "PtEeRsLt.dir"; + mkdir $dir, 0; + @a = File::Glob::glob("$dir/*", GLOB_ERR); + #print "\@a = ", array(@a); + rmdir $dir; + if (scalar(@a) != 0 || GLOB_ERROR == 0) { + print "not "; + } + print "ok 6\n"; +} + +# check for csh style globbing +@a = File::Glob::glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { + print "not "; +} +print "ok 7\n"; + +@a = File::Glob::glob( + '{TES*,doesntexist*,a,b}', + GLOB_BRACE | GLOB_NOMAGIC +); +unless (@a == 3 + and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') + and $a[1] eq 'a' + and $a[2] eq 'b') +{ + print "not "; +} +print "ok 8\n"; + +# "~" should expand to $ENV{HOME} +$ENV{HOME} = "sweet home"; +@a = File::Glob::glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless (@a == 1 and $a[0] eq $ENV{HOME}) { + print "not "; +} +print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t new file mode 100755 index 0000000..32719b2 --- /dev/null +++ b/contrib/perl5/t/lib/glob-case.t @@ -0,0 +1,53 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob("lib/G*.t"); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... +if ($^O ne 'MSWin32') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t new file mode 100755 index 0000000..9d273bd --- /dev/null +++ b/contrib/perl5/t/lib/glob-global.t @@ -0,0 +1,110 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..10\n"; +} +END { + print "not ok 1\n" unless $loaded; +} + +BEGIN { + *CORE::GLOBAL::glob = sub { "Just another Perl hacker," }; +} + +BEGIN { + if ("Just another Perl hacker," ne (<*>)[0]) { + die <<EOMessage; +Your version of perl ($]) doesn't seem to allow extensions to override +the core glob operator. +EOMessage + } +} + +use File::Glob ':globally'; +$loaded = 1; +print "ok 1\n"; + +$_ = "lib/*.t"; +my @r = glob; +print "not " if $_ ne 'lib/*.t'; +print "ok 2\n"; + +# we should have at least basic.t, global.t, taint.t +print "# |@r|\nnot " if @r < 3; +print "ok 3\n"; + +# check if <*/*> works +@r = <*/*.t>; +# at least t/global.t t/basic.t, t/taint.t +print "not " if @r < 3; +print "ok 4\n"; +my $r = scalar @r; + +# check if scalar context works +@r = (); +while (defined($_ = <*/*.t>)) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 5\n"; + +# check if array context works +@r = (); +for (<*/*.t>) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 6\n"; + +# test if implicit assign to $_ in while() works +@r = (); +while (<*/*.t>) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 7\n"; + +# test if explicit glob() gets assign magic too +my @s = (); +while (glob '*/*.t') { + #print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 8\n"; + +# how about in a different package, like? +package Foo; +use File::Glob ':globally'; +@s = (); +while (glob '*/*.t') { + #print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 9\n"; + +# test if different glob ops maintain independent contexts +@s = (); +my $i = 0; +while (<*/*.t>) { + #print "# $_ <"; + push @s, $_; + while (<bas*/*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; +} +print "not " if "@r" ne "@s" or not $i; +print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t new file mode 100755 index 0000000..a8dc213 --- /dev/null +++ b/contrib/perl5/t/lib/glob-taint.t @@ -0,0 +1,26 @@ +#!./perl -T + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..2\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob; +$loaded = 1; +print "ok 1\n"; + +# all filenames should be tainted +@a = File::Glob::glob("*"); +eval { $a = join("",@a), kill 0; 1 }; +unless ($@ =~ /Insecure dependency/) { + print "not "; +} +print "ok 2\n"; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t new file mode 100755 index 0000000..4b25322 --- /dev/null +++ b/contrib/perl5/t/lib/gol-basic.t @@ -0,0 +1,24 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Getopt::Long 2.17; + +print "1..9\n"; + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("no_ignore_case"); +undef $opt_baR; +undef $opt_bar; +print "ok 1\n" if GetOptions ("foo", "Foo=s"); +print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); +print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); +print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); +print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); +print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t new file mode 100755 index 0000000..a4f807c --- /dev/null +++ b/contrib/perl5/t/lib/gol-compat.t @@ -0,0 +1,25 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +require "newgetopt.pl"; + +print "1..9\n"; + +@ARGV = qw(-Foo -baR --foo bar); +$newgetopt::ignorecase = 0; +$newgetopt::ignorecase = 0; +undef $opt_baR; +undef $opt_bar; +print "ok 1\n" if NGetOpt ("foo", "Foo=s"); +print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); +print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); +print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); +print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); +print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t new file mode 100755 index 0000000..a1b2c05 --- /dev/null +++ b/contrib/perl5/t/lib/gol-linkage.t @@ -0,0 +1,37 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Getopt::Long; + +print "1..18\n"; + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("no_ignore_case"); +%lnk = (); +print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s"); +print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n"); +print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n"); +print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n"); +print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n"); + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("default","no_ignore_case"); +%lnk = (); +my $foo; +print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s"); +print ((defined $foo) ? "" : "not ", "ok 10\n"); +print (($foo == 1) ? "" : "not ", "ok 11\n"); +print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n"); +print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 14\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); +print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); +print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); +print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t index 1fa7f63..acb150d 100755 --- a/contrib/perl5/t/lib/h2ph.t +++ b/contrib/perl5/t/lib/h2ph.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..2\n"; @@ -31,4 +31,5 @@ unless(-e '../utils/h2ph') { # cleanup - should this be in an END block? unlink("lib/h2ph.ph"); + unlink("_h2ph_pre.ph"); } diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t index e4ac365..6f61fb9 100755 --- a/contrib/perl5/t/lib/hostname.t +++ b/contrib/perl5/t/lib/hostname.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Sys::Hostname; @@ -15,5 +15,6 @@ if ($@) { print "1..0\n" if $@ =~ /Cannot get host name/; } else { print "1..1\n"; + print "# \$host = `$host'\n"; print "ok 1\n"; } diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t new file mode 100755 index 0000000..48cb6b5 --- /dev/null +++ b/contrib/perl5/t/lib/io_const.t @@ -0,0 +1,33 @@ + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; + +print "1..6\n"; +my $i = 1; +foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) { + my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0; + my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef; + my $v2 = IO::Handle::constant($_); + my $d2 = defined($v2); + + print "not " + if($d1 != $d2 || ($d1 && ($v1 != $v2))); + print "ok ",$i++,"\n"; +} diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t new file mode 100755 index 0000000..11ec8bc --- /dev/null +++ b/contrib/perl5/t/lib/io_dir.t @@ -0,0 +1,66 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } + require Config; import Config; + if ($] < 5.00326 || not $Config{'d_readdir'}) { + print "1..0\n"; + exit 0; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +use IO::Dir qw(DIR_UNLINK); + +print "1..10\n"; + +$dot = new IO::Dir "."; +print defined($dot) ? "ok" : "not ok", " 1\n"; + +@a = sort <*>; +do { $first = $dot->read } while defined($first) && $first =~ /^\./; +print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; + +@b = sort($first, (grep {/^[^.]/} $dot->read)); +print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; + +$dot->rewind; +@c = sort grep {/^[^.]/} $dot->read; +print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; + +$dot->close; +$dot->rewind; +print defined($dot->read) ? "not ok" : "ok", " 5\n"; + +open(FH,'>X') || die "Can't create x"; +print FH "X"; +close(FH); + +tie %dir, IO::Dir, "."; +my @files = keys %dir; + +# I hope we do not have an empty dir :-) +print @files ? "ok" : "not ok", " 6\n"; + +my $stat = $dir{'X'}; +print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1 + ? "ok" : "not ok", " 7\n"; + +delete $dir{'X'}; + +print -f 'X' ? "ok" : "not ok", " 8\n"; + +tie %dirx, IO::Dir, ".", DIR_UNLINK; + +my $statx = $dirx{'X'}; +print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 + ? "ok" : "not ok", " 9\n"; + +delete $dirx{'X'}; + +print -f 'X' ? "not ok" : "ok", " 10\n"; diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t index 6b0caf1..c895fb4 100755 --- a/contrib/perl5/t/lib/io_dup.t +++ b/contrib/perl5/t/lib/io_dup.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t new file mode 100755 index 0000000..3503215 --- /dev/null +++ b/contrib/perl5/t/lib/io_linenum.t @@ -0,0 +1,80 @@ +#!./perl + +# test added 29th April 1999 by Paul Johnson (pjcj@transeda.com) +# updated 28th May 1999 by Paul Johnson + +my $File; + +BEGIN +{ + $File = __FILE__; + if (-d 't') + { + chdir 't'; + $File =~ s/^t\W+//; # Remove first directory + } + unshift @INC, '../lib' if -d '../lib'; + require strict; import strict; +} + +use Test; + +BEGIN { plan tests => 12 } + +use IO::File; + +sub lineno +{ + my ($f) = @_; + my $l; + $l .= "$. "; + $l .= $f->input_line_number; + $l .= " $."; # check $. before and after input_line_number + $l; +} + +my $t; + +open (F, $File) or die $!; +my $io = IO::File->new($File) or die $!; + +<F> for (1 .. 10); +ok(lineno($io), "10 0 10"); + +$io->getline for (1 .. 5); +ok(lineno($io), "5 5 5"); + +<F>; +ok(lineno($io), "11 5 11"); + +$io->getline; +ok(lineno($io), "6 6 6"); + +$t = tell F; # tell F; provokes a warning +ok(lineno($io), "11 6 11"); + +<F>; +ok(lineno($io), "12 6 12"); + +select F; +ok(lineno($io), "12 6 12"); + +<F> for (1 .. 10); +ok(lineno($io), "22 6 22"); + +$io->getline for (1 .. 5); +ok(lineno($io), "11 11 11"); + +$t = tell F; +# We used to have problems here before local $. worked. +# input_line_number() used to use select and tell. When we did the +# same, that mechanism broke. It should work now. +ok(lineno($io), "22 11 22"); + +{ + local $.; + $io->getline for (1 .. 5); + ok(lineno($io), "16 16 16"); +} + +ok(lineno($io), "22 16 22"); diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t new file mode 100755 index 0000000..7337a5f --- /dev/null +++ b/contrib/perl5/t/lib/io_multihomed.t @@ -0,0 +1,124 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } + } +} + +$| = 1; + +print "1..8\n"; + + +package Multi; +require IO::Socket::INET; +@ISA=qw(IO::Socket::INET); + +use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in); + +sub _get_addr +{ + my($sock,$addr_str, $multi) = @_; + #print "_get_addr($sock, $addr_str, $multi)\n"; + + print "not " unless $multi; + print "ok 2\n"; + + ( + # private IP-addresses which I hope does not work anywhere :-) + inet_aton("10.250.230.10"), + inet_aton("10.250.230.12"), + inet_aton("127.0.0.1") # loopback + ) +} + +sub connect +{ + my $self = shift; + if (@_ == 1) { + my($port, $addr) = unpack_sockaddr_in($_[0]); + $addr = inet_ntoa($addr); + #print "connect($self, $port, $addr)\n"; + if($addr eq "10.250.230.10") { + print "ok 3\n"; + return 0; + } + if($addr eq "10.250.230.12") { + print "ok 4\n"; + return 0; + } + } + $self->SUPER::connect(@_); +} + + + +package main; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + Timeout => 5, + ) or die "$!"; + +print "ok 1\n"; + +$port = $listen->sockport; + +if($pid = fork()) { + + $sock = $listen->accept() or die "$!"; + print "ok 5\n"; + + print $sock->getline(); + print $sock "ok 7\n"; + + waitpid($pid,0); + + $sock->close; + + print "ok 8\n"; + +} elsif(defined $pid) { + + $sock = Multi->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => 'localhost', + MultiHomed => 1, + Timeout => 1, + ) or die "$!"; + + print $sock "ok 6\n"; + sleep(1); # race condition + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t index e617c92..bcb89a0 100755 --- a/contrib/perl5/t/lib/io_pipe.t +++ b/contrib/perl5/t/lib/io_pipe.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,10 +11,16 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { - if (! $Config{'d_fork'} || - ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) - { - print "1..0\n"; + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + undef $reason if $^O eq 'VMS'; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; } } diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t new file mode 100755 index 0000000..68ad7b7 --- /dev/null +++ b/contrib/perl5/t/lib/io_poll.t @@ -0,0 +1,77 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +if ($^O eq 'mpeix') { + print "1..0 # Skip: broken on MPE/iX\n"; + exit 0; +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..8\n"; + +use IO::Handle; +use IO::Poll qw(/POLL/); + +my $poll = new IO::Poll; + +my $stdout = \*STDOUT; +my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w"); + +$poll->mask($stdout => POLLOUT); + +print "not " + unless $poll->mask($stdout) == POLLOUT; +print "ok 1\n"; + +$poll->mask($dupout => POLLPRI); + +print "not " + unless $poll->mask($dupout) == POLLPRI; +print "ok 2\n"; + +$poll->poll(0.1); + +if ($^O eq 'MSWin32') { +print "ok 3 # skipped, doesn't work on non-socket fds\n"; +print "ok 4 # skipped, doesn't work on non-socket fds\n"; +} +else { +print "not " + unless $poll->events($stdout) == POLLOUT; +print "ok 3\n"; + +print "not " + if $poll->events($dupout); +print "ok 4\n"; +} + +my @h = $poll->handles; +print "not " + unless @h == 2; +print "ok 5\n"; + +$poll->remove($stdout); + +@h = $poll->handles; + +print "not " + unless @h == 1; +print "ok 6\n"; + +print "not " + if $poll->mask($stdout); +print "ok 7\n"; + +$poll->poll(0.1); + +print "not " + if $poll->events($stdout); +print "ok 8\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t index 3dc651b..85e14ab 100755 --- a/contrib/perl5/t/lib/io_sel.t +++ b/contrib/perl5/t/lib/io_sel.t @@ -3,14 +3,14 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..21\n"; +print "1..23\n"; use IO::Select 1.09; @@ -114,3 +114,19 @@ print "ok 20\n"; $sel->remove($sel->handles); print "not " unless $sel->count == 0 && !defined($sel->bits); print "ok 21\n"; + +# check warnings +$SIG{__WARN__} = sub { + ++ $w + if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ + } ; +$w = 0 ; +IO::Select::has_error(); +print "not " unless $w == 0 ; +$w = 0 ; +print "ok 22\n" ; +use warnings 'IO::Select' ; +IO::Select::has_error(); +print "not " unless $w == 1 ; +$w = 0 ; +print "ok 23\n" ; diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t index 8fc52e4..056d131f 100755 --- a/contrib/perl5/t/lib/io_sock.t +++ b/contrib/perl5/t/lib/io_sock.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,23 +11,34 @@ use Config; BEGIN { if (-d "lib" && -f "TEST") { - if (!$Config{'d_fork'} || - (($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/) && - !(($^O eq 'VMS') && $Config{d_socket}))) { - print "1..0\n"; + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; } } } $| = 1; -print "1..5\n"; +print "1..14\n"; use IO::Socket; $listen = IO::Socket::INET->new(Listen => 2, Proto => 'tcp', + # some systems seem to need as much as 10, + # so be generous with the timeout + Timeout => 15, ) or die "$!"; print "ok 1\n"; @@ -43,7 +54,7 @@ $port = $listen->sockport; if($pid = fork()) { - $sock = $listen->accept(); + $sock = $listen->accept() or die "accept failed: $!"; print "ok 2\n"; $sock->autoflush(1); @@ -69,7 +80,7 @@ if($pid = fork()) { Proto => 'tcp', PeerAddr => 'localhost' ) - or die "$! (maybe your system does not have the 'localhost' address defined)"; + or die "$! (maybe your system does not have the 'localhost' address defined)"; $sock->autoflush(1); @@ -84,8 +95,103 @@ if($pid = fork()) { die; } +# Test various other ways to create INET sockets that should +# also work. +$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!"; +$port = $listen->sockport; + +if($pid = fork()) { + SERVER_LOOP: + while (1) { + last SERVER_LOOP unless $sock = $listen->accept; + while (<$sock>) { + last SERVER_LOOP if /^quit/; + last if /^done/; + print; + } + $sock = undef; + } + $listen->close; +} elsif (defined $pid) { + # child, try various ways to connect + $sock = IO::Socket::INET->new("localhost:$port"); + if ($sock) { + print "not " unless $sock->connected; + print "ok 6\n"; + $sock->print("ok 7\n"); + sleep(1); + print "ok 8\n"; + $sock->print("ok 9\n"); + $sock->print("done\n"); + $sock->close; + } + else { + print "# $@\n"; + print "not ok 6\n"; + print "not ok 7\n"; + print "not ok 8\n"; + print "not ok 9\n"; + } + + # some machines seem to suffer from a race condition here + sleep(2); + + $sock = IO::Socket::INET->new("127.0.0.1:$port"); + if ($sock) { + $sock->print("ok 10\n"); + $sock->print("done\n"); + $sock->close; + } + else { + print "# $@\n"; + print "not ok 10\n"; + } + # some machines seem to suffer from a race condition here + sleep(1); + $sock = IO::Socket->new(Domain => AF_INET, + PeerAddr => "localhost:$port"); + if ($sock) { + $sock->print("ok 11\n"); + $sock->print("quit\n"); + } + $sock = undef; + sleep(1); + exit; +} else { + die; +} +# Then test UDP sockets +$server = IO::Socket->new(Domain => AF_INET, + Proto => 'udp', + LocalAddr => 'localhost'); +$port = $server->sockport; + +if ($^O eq 'mpeix') { + print("ok 12 # skipped\n") +} else { + if ($pid = fork()) { + my $buf; + $server->recv($buf, 100); + print $buf; + } elsif (defined($pid)) { + #child + $sock = IO::Socket::INET->new(Proto => 'udp', + PeerAddr => "localhost:$port"); + $sock->send("ok 12\n"); + sleep(1); + $sock->send("ok 12\n"); # send another one to be sure + exit; + } else { + die; + } +} +print "not " unless $server->blocking; +print "ok 13\n"; +$server->blocking(0); +print "not " if $server->blocking; +print "ok 14\n"; diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t index 0ef2cfd..deaa6c7 100755 --- a/contrib/perl5/t/lib/io_taint.t +++ b/contrib/perl5/t/lib/io_taint.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t index 2009d61..8d75242 100755 --- a/contrib/perl5/t/lib/io_tell.t +++ b/contrib/perl5/t/lib/io_tell.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; $tell_file = "TEST"; } else { diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index ad2632d..3d5145e 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,18 +11,48 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { - if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/ || - ($^O eq 'os2') || $^O eq 'apollo') && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; + my $reason; + + if ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket was not built'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO was not built'; + } + elsif ($^O eq 'apollo') { + $reason = "unknown *FIXME*"; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; - } + } + } +} + +sub compare_addr { + no utf8; + my $a = shift; + my $b = shift; + if (length($a) != length $b) { + my $min = (length($a) < length $b) ? length($a) : length $b; + if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) { + printf "# Apparently: %d bytes junk at the end of %s\n# %s\n", + abs(length($a) - length ($b)), + $_[length($a) < length ($b) ? 1 : 0], + "consider decreasing bufsize of recfrom."; + substr($a, $min) = ""; + substr($b, $min) = ""; + } + return 0; } + my @a = unpack_sockaddr_in($a); + my @b = unpack_sockaddr_in($b); + "$a[0]$a[1]" eq "$b[0]$b[1]"; } $| = 1; -print "1..3\n"; +print "1..7\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); @@ -35,14 +65,34 @@ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') or die "$! (maybe your system does not have the 'localhost' address defined)"; + +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)"; -print "ok 1\n"; +print "ok 2\n"; -$udpa->send("ok 2\n",0,$udpb->sockname); -$udpb->recv($buf="",5); +$udpa->send("ok 4\n",0,$udpb->sockname); + +print "not " + unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'); +print "ok 3\n"; + +my $where = $udpb->recv($buf="",5); print $buf; -$udpb->send("ok 3\n"); + +my @xtra = (); + +unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) { + print "not "; + @xtra = (0,$udpa->sockname); +} +print "ok 5\n"; + +$udpb->send("ok 6\n",@xtra); $udpa->recv($buf="",5); print $buf; + +print "not " if $udpa->connected; +print "ok 7\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t new file mode 100755 index 0000000..247647a --- /dev/null +++ b/contrib/perl5/t/lib/io_unix.t @@ -0,0 +1,89 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + elsif ($^O eq 'os2') { + require IO::Socket; + + eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1} + or $@ !~ /not implemented/ or + $reason = 'compiled without TCP/IP stack v4'; + } elsif ($^O eq 'qnx') { + $reason = 'Not implemented'; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } + } +} + +$PATH = "/tmp/sock-$$"; + +# Test if we can create the file within the tmp directory +if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') { + print "1..0 # Skip: cannot open '$PATH' for write\n"; + exit 0; +} +close(TEST); +unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; + +# Start testing +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!"; +print "ok 1\n"; + +if($pid = fork()) { + + $sock = $listen->accept(); + print "ok 2\n"; + + print $sock->getline(); + + print $sock "ok 4\n"; + + $sock->close; + + waitpid($pid,0); + unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!"; + + print "ok 5\n"; + +} elsif(defined $pid) { + + $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!"; + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t index 1a6fd38..6bbba16 100755 --- a/contrib/perl5/t/lib/io_xs.t +++ b/contrib/perl5/t/lib/io_xs.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t index 30ea48d..a4f3e3f 100755 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -3,22 +3,27 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_msg'} eq 'define' && - $Config{'d_sem'} eq 'define') { - print "1..0\n"; - exit; + my $reason; + + if ($Config{'d_sem'} ne 'define') { + $reason = '$Config{d_sem} undefined'; + } elsif ($Config{'d_msg'} ne 'define') { + $reason = '$Config{d_msg} undefined'; + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; } } # These constants are common to all tests. # Later the sem* tests will import more for themselves. -use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID - S_IRWXU S_IRWXG S_IRWXO); +use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); use strict; print "1..16\n"; @@ -49,11 +54,14 @@ EOM exit(1); }; +my $perm = S_IRWXU; + if ($Config{'d_msgget'} eq 'define' && $Config{'d_msgctl'} eq 'define' && $Config{'d_msgsnd'} eq 'define' && $Config{'d_msgrcv'} eq 'define') { - $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO); + + $msg = msgget(IPC_PRIVATE, $perm); # Very first time called after machine is booted value may be 0 die "msgget failed: $!\n" unless defined($msg) && $msg >= 0; @@ -63,8 +71,34 @@ if ($Config{'d_msgget'} eq 'define' && my $msgtype = 1; my $msgtext = "hello"; - msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; + my $test2bad; + my $test5bad; + my $test6bad; + + unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) { + print "not "; + $test2bad = 1; + } print "ok 2\n"; + if ($test2bad) { + print <<EOM; +# +# The failure of the subtest #2 may indicate that the message queue +# resource limits either of the system or of the testing account +# have been reached. Error message "Operating would block" is +# usually indicative of this situation. The error message was now: +# "$!" +# +# You can check the message queues with the 'ipcs' command and +# you can remove unneeded queues with the 'ipcrm -q id' command. +# You may also consider configuring your system or account +# to have more message queue resources. +# +# Because of the subtest #2 failing also the substests #5 and #6 will +# very probably also fail. +# +EOM + } my $data; msgctl($msg,IPC_STAT,$data) or print "not "; @@ -74,13 +108,33 @@ if ($Config{'d_msgget'} eq 'define' && print "ok 4\n"; my $msgbuf; - msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not "; + unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { + print "not "; + $test5bad = 1; + } print "ok 5\n"; + if ($test5bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } - my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); - - print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); + my($rmsgtype,$rmsgtext); + ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf); + unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { + print "not "; + $test6bad = 1; + } print "ok 6\n"; + if ($test6bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } } else { for (1..6) { print "ok $_\n"; # fake it @@ -90,80 +144,64 @@ if ($Config{'d_msgget'} eq 'define' && if($Config{'d_semget'} eq 'define' && $Config{'d_semctl'} eq 'define') { - use IPC::SysV qw(IPC_CREAT GETALL SETALL); + if ($Config{'d_semctl_semid_ds'} eq 'define' || + $Config{'d_semctl_semun'} eq 'define') { - $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT); - # Very first time called after machine is booted value may be 0 - die "semget: $!\n" unless defined($sem) && $sem >= 0; + use IPC::SysV qw(IPC_CREAT GETALL SETALL); - print "ok 7\n"; + $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT); + # Very first time called after machine is booted value may be 0 + die "semget: $!\n" unless defined($sem) && $sem >= 0; - my $data; - semctl($sem,0,IPC_STAT,$data) or print "not "; - print "ok 8\n"; + print "ok 7\n"; - print "not " unless length($data); - print "ok 9\n"; - - my $template; - - # Find the pack/unpack template capable of handling native C shorts. - - if ($Config{shortsize} == 2) { - $template = "s"; - } elsif ($Config{shortsize} == 4) { - $template = "l"; - } elsif ($Config{shortsize} == 8) { - # Try quad last because not supported everywhere. - foreach my $t (qw(i q)) { - # We could trap the unsupported quad template with eval - # but if we get this far we should have quad support anyway. - if (length(pack($t, 0)) == 8) { - $template = $t; - last; - } - } - } - - die "$0: cannot pack native shorts\n" unless defined $template; - - $template .= "*"; + my $data; + semctl($sem,0,IPC_STAT,$data) or print "not "; + print "ok 8\n"; + + print "not " unless length($data); + print "ok 9\n"; - my $nsem = 10; + my $nsem = 10; - semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not "; - print "ok 10\n"; + semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not "; + print "ok 10\n"; - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 11\n"; + $data = ""; + semctl($sem,0,GETALL,$data) or print "not "; + print "ok 11\n"; - print "not " unless length($data) == length(pack($template,(0) x $nsem)); - print "ok 12\n"; + print "not " unless length($data) == length(pack("s!*",(0) x $nsem)); + print "ok 12\n"; - my @data = unpack($template,$data); + my @data = unpack("s!*",$data); - my $adata = "0" x $nsem; + my $adata = "0" x $nsem; - print "not " unless @data == $nsem and join("",@data) eq $adata; - print "ok 13\n"; + print "not " unless @data == $nsem and join("",@data) eq $adata; + print "ok 13\n"; - my $poke = 2; + my $poke = 2; - $data[$poke] = 1; - semctl($sem,0,SETALL,pack($template,@data)) or print "not "; - print "ok 14\n"; + $data[$poke] = 1; + semctl($sem,0,SETALL,pack("s!*",@data)) or print "not "; + print "ok 14\n"; - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 15\n"; + $data = ""; + semctl($sem,0,GETALL,$data) or print "not "; + print "ok 15\n"; - @data = unpack($template,$data); + @data = unpack("s!*",$data); - my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); + my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); - print "not " unless join("",@data) eq $bdata; - print "ok 16\n"; + print "not " unless join("",@data) eq $bdata; + print "ok 16\n"; + } else { + for (7..16) { + print "ok $_ # skipped, no semctl possible\n"; + } + } } else { for (7..16) { print "ok $_\n"; # fake it diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t index a97dbd1..39c3f40 100755 --- a/contrib/perl5/t/lib/ndbm.t +++ b/contrib/perl5/t/lib/ndbm.t @@ -4,10 +4,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: NDBM_File was not built\n"; exit 0; } } @@ -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..18\n"; +print "1..64\n"; unlink <Op.dbmx*>; @@ -205,3 +205,189 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(20, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(21, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(22, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(24, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(25, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(26, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(29, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(30, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(31, $h{"fred"} eq "joe"); + ok(32, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $db->FIRSTKEY() eq "fred") ; + ok(34, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(35, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(36, $h{"fred"} eq "joe"); + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $db->FIRSTKEY() eq "fred") ; + ok(39, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, $result{"fetch value"} eq ""); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t index 8ba9bcf..f8b8a11 100755 --- a/contrib/perl5/t/lib/odbm.t +++ b/contrib/perl5/t/lib/odbm.t @@ -4,10 +4,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bODBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: ODBM_File was not built\n"; exit 0; } } @@ -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..18\n"; +print "1..64\n"; unlink <Op.dbmx*>; @@ -205,3 +205,202 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + print "# ", join('|', $fetch_key, $fk, $store_key, $sk, + $fetch_value, $fv, $store_value, $sv, $_), "\n"; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(20, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(21, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(22, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(24, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(25, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(26, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(29, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(30, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(31, $h{"fred"} eq "joe"); + ok(32, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $db->FIRSTKEY() eq "fred") ; + ok(34, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(35, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(36, $h{"fred"} eq "joe"); + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $db->FIRSTKEY() eq "fred") ; + ok(39, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, $result{"fetch value"} eq ""); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +if ($^O eq 'hpux') { + print <<EOM; +# +# If you experience failures with the odbm test in HP-UX, +# this is a well-known bug that's unfortunately very hard to fix. +# The suggested course of action is to avoid using the ODBM_File, +# but to use instead the NDBM_File extension. +# +EOM +} diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t index a785fce..f83a689 100755 --- a/contrib/perl5/t/lib/opcode.t +++ b/contrib/perl5/t/lib/opcode.t @@ -4,7 +4,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t index 85b807c..6443112 100755 --- a/contrib/perl5/t/lib/open2.t +++ b/contrib/perl5/t/lib/open2.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t index b84dac9..7cd0ca3 100755 --- a/contrib/perl5/t/lib/open3.t +++ b/contrib/perl5/t/lib/open3.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) @@ -49,7 +49,7 @@ my ($pid, $reaped_pid); STDOUT->autoflush; STDERR->autoflush; -print "1..21\n"; +print "1..22\n"; # basic ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); @@ -134,3 +134,17 @@ EOF print WRITE "ok 20\n"; print WRITE "ok 21\n"; waitpid $pid, 0; + +# command line in single parameter variant of open3 +# for understanding of Config{'sh'} test see exec description in camel book +my $cmd = 'print(scalar(<STDIN>))'; +$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); +eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; }; +if ($@) { + print "error $@\n"; + print "not ok 22\n"; +} +else { + print WRITE "ok 22\n"; + waitpid $pid, 0; +} diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t index 56b1bac..ce8b6d0 100755 --- a/contrib/perl5/t/lib/ops.t +++ b/contrib/perl5/t/lib/ops.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 3c5e75b..2c936f1 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -2,9 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use warnings; use Text::ParseWords; print "1..18\n"; @@ -17,15 +18,15 @@ print "ok 2\n"; print "not " if $words[2] ne 'zoo'; print "ok 3\n"; -# Gonna get some undefined things back -local($^W) = 0; +{ + # Gonna get some undefined things back + no warnings 'uninitialized' ; -# Test quotewords() with other parameters and null last field -@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); -print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); -print "ok 4\n"; - -$^W = 1; + # Test quotewords() with other parameters and null last field + @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); + print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); + print "ok 4\n"; +} # Test $keep eq 'delimiters' and last field zero @words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); @@ -71,29 +72,30 @@ print "ok 11\n"; print "not " if (@words); print "ok 12\n"; -# Gonna get some more undefined things back -$^W = 0; +{ + # Gonna get some more undefined things back + no warnings 'uninitialized' ; -@words = nested_quotewords('s+', 0, $string); -print "not " if (@words); -print "ok 13\n"; + @words = nested_quotewords('s+', 0, $string); + print "not " if (@words); + print "ok 13\n"; -# Now test empty fields -$result = join('|', parse_line(':', 0, 'foo::0:"":::')); -print "not " unless ($result eq 'foo||0||||'); -print "ok 14\n"; + # Now test empty fields + $result = join('|', parse_line(':', 0, 'foo::0:"":::')); + print "not " unless ($result eq 'foo||0||||'); + print "ok 14\n"; -# Test for 0 in quotes without $keep -$result = join('|', parse_line(':', 0, ':"0":')); -print "not " unless ($result eq '|0|'); -print "ok 15\n"; + # Test for 0 in quotes without $keep + $result = join('|', parse_line(':', 0, ':"0":')); + print "not " unless ($result eq '|0|'); + print "ok 15\n"; -# Test for \001 in quoted string -$result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); -print "not " unless ($result eq "|\1|"); -print "ok 16\n"; + # Test for \001 in quoted string + $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); + print "not " unless ($result eq "|\1|"); + print "ok 16\n"; -$^W = 1; +} # Now test perlish single quote behavior $Text::ParseWords::PERL_SINGLE_QUOTE = 1; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t index de27dee..dd24c79 100755 --- a/contrib/perl5/t/lib/ph.t +++ b/contrib/perl5/t/lib/ph.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } # All the constants which Socket.pm tries to make available: diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index f6d8e92..abc4563 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { print "1..0\n"; @@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); use strict subs; $| = 1; -print "1..18\n"; +print "1..27\n"; $Is_W32 = $^O eq 'MSWin32'; @@ -72,6 +72,9 @@ print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; if ($Config{d_strtod}) { $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); +# Using long double NVs may introduce greater accuracy than wanted. + $n =~ s/^3.14158999\d*$/3.14159/ + if $Config{uselongdouble} eq 'define'; print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n"); &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; } else { print "# strtod not present\n", "ok 14\n"; } @@ -95,6 +98,32 @@ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; # See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); +# If that worked, validate the mini_mktime() routine's normalisation of +# input fields to strftime(). +sub try_strftime { + my $num = shift; + my $expect = shift; + my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); + if ($got eq $expect) { + print "ok $num\n"; + } + else { + print "# expected: $expect\n# got: $got\nnot ok $num\n"; + } +} + +$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; +try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); +try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); +try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); +try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); +try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); +try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); +try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); +try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); +try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); +&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; + $| = 0; # The following line assumes buffered output, which may be not true with EMX: print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t index 27993d9..6e12873 100755 --- a/contrib/perl5/t/lib/safe1.t +++ b/contrib/perl5/t/lib/safe1.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index 6afc117..293b515 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; @@ -10,6 +10,7 @@ BEGIN { } # test 30 rather naughtily expects English error messages $ENV{'LC_ALL'} = 'C'; + $ENV{LANGUAGE} = 'C'; # GNU locale extension } # Tests Todo: @@ -65,7 +66,7 @@ $glob = "ok 11\n"; sub sayok { print "ok @_\n" } $cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{archname} =~ /-thread$/; +$cpt->share('$"') unless $Config{use5005threads}; $cpt->reval(q{ package other; @@ -123,7 +124,7 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); # The regexp is getting rather baroque. -print $! =~ /No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; +print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; # test #31 is gone. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t index 591fe14..2689d19 100755 --- a/contrib/perl5/t/lib/sdbm.t +++ b/contrib/perl5/t/lib/sdbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ print "1..0\n"; @@ -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..18\n"; +print "1..66\n"; unlink <Op_dbmx.*>; @@ -122,13 +122,6 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -untie %h; -if ($^O eq 'VMS') { - unlink 'Op_dbmx.sdbm_dir', $Dfile; -} else { - unlink 'Op_dbmx.dir', $Dfile; -} - sub ok { @@ -210,3 +203,196 @@ EOM unlink "SubDB.pm", <dbhash_tmp.*> ; } + +ok(19, !exists $h{'goner1'}); +ok(20, exists $h{'foo'}); + +untie %h; +unlink <Op_dbmx*>, $Dfile; + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op_dbmx*>; + ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(22, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(24, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(25, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(26, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(27, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(30, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(31, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(32, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $h{"fred"} eq "joe"); + ok(34, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(35, $db->FIRSTKEY() eq "fred") ; + ok(36, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $h{"fred"} eq "joe"); + ok(39, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(40, $db->FIRSTKEY() eq "fred") ; + ok(41, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op_dbmx*>; + ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, $result{"fetch value"} eq ""); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op_dbmx*>; + + ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index c36fdb8..46cea39 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..4\n"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t index 3b58d70..677caec 100755 --- a/contrib/perl5/t/lib/selectsaver.t +++ b/contrib/perl5/t/lib/selectsaver.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t index 4e38295..d5e1848 100755 --- a/contrib/perl5/t/lib/socket.t +++ b/contrib/perl5/t/lib/socket.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && !(($^O eq 'VMS') && $Config{d_socket})) { @@ -13,7 +13,7 @@ BEGIN { use Socket; -print "1..6\n"; +print "1..8\n"; if (socket(T,PF_INET,SOCK_STREAM,6)) { print "ok 1\n"; @@ -74,3 +74,14 @@ else { print "# $!\n"; print "not ok 4\n"; } + +# warnings +$SIG{__WARN__} = sub { + ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; +} ; +$w = 0 ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; +use warnings 'Socket' ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t index d35f264..a04cccd 100755 --- a/contrib/perl5/t/lib/soundex.t +++ b/contrib/perl5/t/lib/soundex.t @@ -18,7 +18,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Text::Soundex; diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t index 03449a3..14c919c 100755 --- a/contrib/perl5/t/lib/symbol.t +++ b/contrib/perl5/t/lib/symbol.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t new file mode 100755 index 0000000..2857120 --- /dev/null +++ b/contrib/perl5/t/lib/syslfs.t @@ -0,0 +1,221 @@ +# NOTE: this file tests how large files (>2GB) work with raw system IO. +# stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t. +# If you modify/add tests here, remember to update also t/op/lfs.t. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + # Don't bother if there are no quad offsets. + if ($Config{lseeksize} < 8) { + print "1..0\n# no 64-bit file offsets\n"; + exit(0); + } + require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); +} + +sub zap { + close(BIG); + unlink("big"); + unlink("big1"); + unlink("big2"); +} + +sub bye { + zap(); + exit(0); +} + +sub explain { + 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.) +# +# Perl may still be able to support large files, once you have +# such a process, enough quota, and such a (file) system. +# +EOM +} + +print "# checking whether we have sparse files...\n"; + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files (because this is $^O) \n"; + bye(); +} + +# Known haves that have problems running this test +# (for example because they do not support sparse files, like UNICOS) +if ($^O eq 'unicos') { + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + bye(); +} + +# Then try heuristically to deduce whether we have sparse files. + +# We'll start off by creating a one megabyte file which has +# only three "true" bytes. If we have sparseness, we should +# consume less blocks than one megabyte (assuming nobody has +# one megabyte blocks...) + +sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen big1 failed: $!\n"; bye }; +sysseek(BIG, 1_000_000, SEEK_SET) or + do { warn "sysseek big1 failed: $!\n"; bye }; +syswrite(BIG, "big") or + do { warn "syswrite big1 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big1 failed: $!\n"; bye }; + +my @s1 = stat("big1"); + +print "# s1 = @s1\n"; + +sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen big2 failed: $!\n"; bye }; +sysseek(BIG, 2_000_000, SEEK_SET) or + do { warn "sysseek big2 failed: $!\n"; bye }; +syswrite(BIG, "big") or + do { warn "syswrite big2 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big2 failed: $!\n"; bye }; + +my @s2 = stat("big2"); + +print "# s2 = @s2\n"; + +zap(); + +unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && + $s1[11] == $s2[11] && $s1[12] == $s2[12]) { + print "1..0\n#no sparse files?\n"; + bye; +} + +print "# we seem to have sparse files...\n"; + +# By now we better be sure that we do have sparse files: +# if we are not, the following will hog 5 gigabytes of disk. Ooops. + +$ENV{LC_ALL} = "C"; + +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen 'big' failed: $!\n"; bye }; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +unless (defined $sysseek && $sysseek == 5_000_000_000) { + print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", + defined $sysseek ? $sysseek : 'undef', ")\n"; + explain(); + bye(); +} + +# The syswrite will fail if there are are filesize limitations (process or fs). +my $syswrite = syswrite(BIG, "big"); +print "# syswrite failed: $! (syswrite returned ", + defined $syswrite ? $syswrite : 'undef', ")\n" + unless defined $syswrite && $syswrite == 3; +my $close = close BIG; +print "# close failed: $!\n" unless $close; +unless($syswrite && $close) { + if ($! =~/too large/i) { + print "1..0\n# writing past 2GB failed: process limits?\n"; + } elsif ($! =~ /quota/i) { + print "1..0\n# filesystem quota limits?\n"; + } + explain(); + bye(); +} + +@s = stat("big"); + +print "# @s\n"; + +unless ($s[7] == 5_000_000_003) { + print "1..0\n# not configured to use large files?\n"; + explain(); + bye(); +} + +sub fail () { + print "not "; + $fail++; +} + +print "1..17\n"; + +my $fail = 0; + +fail unless $s[7] == 5_000_000_003; # exercizes pp_stat +print "ok 1\n"; + +fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize +print "ok 2\n"; + +fail unless -e "big"; +print "ok 3\n"; + +fail unless -f "big"; +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; +print "ok 5\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +print "ok 6\n"; + +fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001; +print "ok 7\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001; +print "ok 8\n"; + +fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000; +print "ok 9\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +print "ok 10\n"; + +fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000; +print "ok 11\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000; +print "ok 12\n"; + +my $big; + +fail unless sysread(BIG, $big, 3) == 3; +print "ok 13\n"; + +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); +print "ok 15\n"; + +my $zero; + +fail unless read(BIG, $zero, 3) == 3; +print "ok 16\n"; + +fail unless $zero eq "\0\0\0"; +print "ok 17\n"; + +explain if $fail; + +bye(); # does the necessary cleanup + +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + +# eof diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t index 19add69..daeee23 100755 --- a/contrib/perl5/t/lib/textfill.t +++ b/contrib/perl5/t/lib/textfill.t @@ -2,9 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use Text::Wrap qw(&fill); + @tests = (split(/\nEND\n/s, <<DONE)); TEST1 Cyberdog Information diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t index ea9012c..80395f4 100755 --- a/contrib/perl5/t/lib/texttabs.t +++ b/contrib/perl5/t/lib/texttabs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index c3a455b..bb1d5ca 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -2,8 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use Text::Wrap qw(&wrap); @tests = (split(/\nEND\n/s, <<DONE)); TEST1 diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t new file mode 100755 index 0000000..6b3c800 --- /dev/null +++ b/contrib/perl5/t/lib/thr5005.t @@ -0,0 +1,118 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if (! $Config{'use5005threads'}) { + print "1..0 # Skip: not use5005threads\n"; + exit 0; + } + + # XXX known trouble with global destruction + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +$| = 1; +print "1..21\n"; +use Thread 'yield'; +print "ok 1\n"; + +sub content +{ + print shift; + return shift; +} + +# create a thread passing args and immedaietly wait for it. +my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); +print $t->join; + +# check that lock works ... +{lock $foo; + $t = new Thread sub { lock $foo; print "ok 5\n" }; + print "ok 4\n"; +} +$t->join; + +sub dorecurse +{ + my $val = shift; + my $ret; + print $val; + if (@_) + { + $ret = Thread->new(\&dorecurse, @_); + $ret->join; + } +} + +$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; +$t->join; + +# test that sleep lets other thread run +$t = new Thread \&dorecurse,"ok 11\n"; +sleep 6; +print "ok 12\n"; +$t->join; + +sub islocked : locked { + my $val = shift; + my $ret; + print $val; + if (@_) + { + $ret = Thread->new(\&islocked, shift); + } + $ret; +} + +$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); +$t->join->join; + +{ + package Loch::Ness; + sub new { bless [], shift } + sub monster : locked : method { + my($s, $m) = @_; + print "ok $m\n"; + } + sub gollum { &monster } +} +Loch::Ness->monster(15); +Loch::Ness->new->monster(16); +Loch::Ness->gollum(17); +Loch::Ness->new->gollum(18); + +my $short = "This is a long string that goes on and on."; +my $shorte = " a long string that goes on and on."; +my $long = "This is short."; +my $longe = " short."; +my $thr1 = new Thread \&threaded, $short, $shorte, "19"; +my $thr2 = new Thread \&threaded, $long, $longe, "20"; + +sub threaded { + my ($string, $string_end, $testno) = @_; + + # Do the match, saving the output in appropriate variables + $string =~ /(.*)(is)(.*)/; + # Yield control, allowing the other thread to fill in the match variables + yield(); + # Examine the match variable contents; on broken perls this fails + if ($3 eq $string_end) { + print "ok $testno\n"; + } + else { + warn <<EOT; + +# +# This is a KNOWN FAILURE, and one of the reasons why threading +# is still an experimental feature. It is here to stop people +# from deploying threads in production. ;-) +# +EOT + print "not ok $testno # other thread filled in match variables\n"; + } +} +$thr1->join; +$thr2->join; +print "ok 21\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t index dd718de..23a0a94 100755 --- a/contrib/perl5/t/lib/tie-push.t +++ b/contrib/perl5/t/lib/tie-push.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } { @@ -21,4 +21,4 @@ tie @x,Basic; tie @get,Basic; tie @got,Basic; tie @tests,Basic; -require "../t/op/push.t" +require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t index 7ca4d76..5a678a5 100755 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Tie::Array; tie @foo,Tie::StdArray; tie @ary,Tie::StdArray; tie @bar,Tie::StdArray; -require "../t/op/array.t" +require "op/array.t" diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t new file mode 100755 index 0000000..cf3a183 --- /dev/null +++ b/contrib/perl5/t/lib/tie-stdhandle.t @@ -0,0 +1,47 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Tie::Handle; +tie *tst,Tie::StdHandle; + +$f = 'tst'; + +print "1..13\n"; + +# my $file tests + +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile"); +print "ok 1\n"; +print "$!\nnot " unless binmode($f); +print "ok 2\n"; +print "not " unless -f "afile"; +print "ok 3\n"; +print "not " unless print $f "SomeData\n"; +print "ok 4\n"; +print "not " unless tell($f) == 9; +print "ok 5\n"; +print "not " unless printf $f "Some %d value\n",1234; +print "ok 6\n"; +print "not " unless seek($f,0,0); +print "ok 7\n"; +$b = <$f>; +print "not " unless $b eq "SomeData\n"; +print "ok 8\n"; +print "not " if eof($f); +print "ok 9\n"; +read($f,($b=''),4); +print "'$b' not " unless $b eq 'Some'; +print "ok 10\n"; +print "not " unless getc($f) eq ' '; +print "ok 11\n"; +$b = <$f>; +print "not " unless eof($f); +print "ok 12\n"; +print "not " unless close($f); +print "ok 13\n"; +unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t index 34a6947..35ae1b8 100755 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -2,9 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Tie::Array; tie @x,Tie::StdArray; -require "../t/op/push.t" +require "op/push.t" diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t index 100e076..359d71e 100755 --- a/contrib/perl5/t/lib/timelocal.t +++ b/contrib/perl5/t/lib/timelocal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Time::Local; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t index 3114176..20669f0 100755 --- a/contrib/perl5/t/lib/trig.t +++ b/contrib/perl5/t/lib/trig.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::Trig; diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t new file mode 100755 index 0000000..60f72c3 --- /dev/null +++ b/contrib/perl5/t/op/64bitint.t @@ -0,0 +1,242 @@ +#./perl + +BEGIN { + eval { my $q = pack "q", 0 }; + if ($@) { + print "1..0\n# no 64-bit types\n"; + exit(0); + } + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# This could use a lot of more tests. + +# so that using > 0xfffffff constants and +# 32+ bit integers don't cause noise +no warnings qw(overflow portable); + +print "1..48\n"; + +my $q = 12345678901; +my $r = 23456789012; +my $f = 0xffffffff; +my $x; +my $y; + +$x = unpack "q", pack "q", $q; +print "not " unless $x == $q && $x > $f; +print "ok 1\n"; + + +$x = sprintf("%lld", 12345678901); +print "not " unless $x eq $q && $x > $f; +print "ok 2\n"; + + +$x = sprintf("%lld", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 3\n"; + +$x = sprintf("%Ld", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 4\n"; + +$x = sprintf("%qd", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 5\n"; + + +$x = sprintf("%llx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 6\n"; + +$x = sprintf("%Lx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 7\n"; + +$x = sprintf("%qx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 8\n"; + + +$x = sprintf("%llo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 9\n"; + +$x = sprintf("%Lo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 10\n"; + +$x = sprintf("%qo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 11\n"; + + +$x = sprintf("%llb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 12\n"; + +$x = sprintf("%Lb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 13\n"; + +$x = sprintf("%qb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 14\n"; + + +$x = sprintf("%llu", $q); +print "not " unless $x eq $q && $x > $f; +print "ok 15\n"; + +$x = sprintf("%Lu", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 16\n"; + +$x = sprintf("%qu", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 17\n"; + + +$x = sprintf("%D", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 18\n"; + +$x = sprintf("%U", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 19\n"; + +$x = sprintf("%O", $q); +print "not " unless oct($x) == $q && oct($x) > $f; +print "ok 20\n"; + + +$x = $q + $r; +print "not " unless $x == 35802467913 && $x > $f; +print "ok 21\n"; + +$x = $q - $r; +print "not " unless $x == -11111110111 && -$x > $f; +print "ok 22\n"; + +$x = $q * 1234567; +print "not " unless $x == 15241567763770867 && $x > $f; +print "ok 23\n"; + +$x /= 1234567; +print "not " unless $x == $q && $x > $f; +print "ok 24\n"; + +$x = 98765432109 % 12345678901; +print "not " unless $x == 901; +print "ok 25\n"; + +# The following 12 tests adapted from op/inc. + +$a = 9223372036854775807; +$c = $a++; +print "not " unless $a == 9223372036854775808; +print "ok 26\n"; + +$a = 9223372036854775807; +$c = ++$a; +print "not " unless $a == 9223372036854775808 && $c == $a; +print "ok 27\n"; + +$a = 9223372036854775807; +$c = $a + 1; +print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; +print "ok 28\n"; + +$a = -9223372036854775808; +$c = $a--; +print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; +print "ok 29\n"; + +$a = -9223372036854775808; +$c = --$a; +print "not " unless $a == -9223372036854775809 && $c == $a; +print "ok 30\n"; + +$a = -9223372036854775808; +$c = $a - 1; +print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; +print "ok 31\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = $a--; +print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; +print "ok 32\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = --$a; +print "not " unless $a == -9223372036854775809 && $c == $a; +print "ok 33\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = $a - 1; +print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; +print "ok 34\n"; + +$a = 9223372036854775808; +$b = -$a; +$c = $b--; +print "not " unless $b == -$a-1 && $c == -$a; +print "ok 35\n"; + +$a = 9223372036854775808; +$b = -$a; +$c = --$b; +print "not " unless $b == -$a-1 && $c == $b; +print "ok 36\n"; + +$a = 9223372036854775808; +$b = -$a; +$b = $b - 1; +print "not " unless $b == -(++$a); +print "ok 37\n"; + + +$x = ''; +print "not " unless (vec($x, 1, 64) = $q) == $q; +print "ok 38\n"; + +print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f; +print "ok 39\n"; + +print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0; +print "ok 40\n"; + + +print "not " unless ~0 == 0xffffffffffffffff; +print "ok 41\n"; + +print "not " unless (0xffffffff<<32) == 0xffffffff00000000; +print "ok 42\n"; + +print "not " unless ((0xffffffff)<<32)>>32 == 0xffffffff; +print "ok 43\n"; + +print "not " unless 1<<63 == 0x8000000000000000; +print "ok 44\n"; + +print "not " unless (sprintf "%#Vx", 1<<63) eq '0x8000000000000000'; +print "ok 45\n"; + +print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; +print "ok 46\n"; + +print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "ok 47\n"; + +print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "ok 48\n"; + +# eof diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t new file mode 100755 index 0000000..48bf5afe --- /dev/null +++ b/contrib/perl5/t/op/args.t @@ -0,0 +1,54 @@ +#!./perl + +print "1..8\n"; + +# test various operations on @_ + +my $ord = 0; +sub new1 { bless \@_ } +{ + my $x = new1("x"); + my $y = new1("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } +{ + my $x = new2("x"); + my $y = new2("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} + +sub new3 { goto &new1 } +{ + my $x = new3("x"); + my $y = new3("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new4 { goto &new2 } +{ + my $x = new4("x"); + my $y = new4("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t index 43af807..fe2f0f4 100755 --- a/contrib/perl5/t/op/arith.t +++ b/contrib/perl5/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..4\n"; +print "1..8\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -10,3 +10,14 @@ try 1, 13 % 4 == 1; try 2, -13 % 4 == 3; try 3, 13 % -4 == -3; try 4, -13 % -4 == -1; + +my $limit = 1e6; + +# Division (and modulo) of floating point numbers +# seem to be rather sloppy in Cray. +$limit = 1e8 if $^O eq 'unicos'; + +try 5, abs( 13e21 % 4e21 - 1e21) < $limit; +try 6, abs(-13e21 % 4e21 - 3e21) < $limit; +try 7, abs( 13e21 % -4e21 - -3e21) < $limit; +try 8, abs(-13e21 % -4e21 - -1e21) < $limit; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 3409556..1108f49 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..65\n"; +print "1..66\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -211,3 +211,8 @@ my $t = 63; sub reify { $_[1] = ++$t; print "@_\n"; } reify('ok'); reify('ok'); + +# qw() is no more a runtime split, it's compiletime. +print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; +print "ok 66\n"; + diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t index 57e89c4..b95cec5 100755 --- a/contrib/perl5/t/op/assignwarn.t +++ b/contrib/perl5/t/op/assignwarn.t @@ -8,12 +8,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; +use warnings; -$^W = 1; my $warn = ""; $SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t new file mode 100755 index 0000000..615e4d3 --- /dev/null +++ b/contrib/perl5/t/op/attrs.t @@ -0,0 +1,176 @@ +#!./perl -w + +# Regression tests for attributes.pm and the C< : attrs> syntax. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +sub NTESTS () ; + +my ($test, $ntests); +BEGIN {$ntests=0} +$test=0; +my $failed = 0; + +print "1..".NTESTS."\n"; + +$SIG{__WARN__} = sub { die @_ }; + +sub mytest { + if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { + if ($@) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# Got: $x\n" + } + else { + print "# Got unexpected success\n"; + } + if ($_[0]) { + print "# Expected: $_[0]\n"; + } + else { + print "# Expected success\n"; + } + $failed = 1; + print "not "; + } + elsif (@_ == 3 && $_[1] ne $_[2]) { + print "# Got: $_[1]\n"; + print "# Expected: $_[2]\n"; + $failed = 1; + print "not "; + } + print "ok ",++$test,"\n"; +} + +eval 'sub t1 ($) : locked { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +eval 'sub t2 : locked { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +eval 'sub t3 ($) : locked ;'; +mytest; +BEGIN {++$ntests} + +eval 'sub t4 : locked ;'; +mytest; +BEGIN {++$ntests} + +my $anon1; +eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +my $anon2; +eval '$anon2 = sub : locked : method { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +my $anon3; +eval '$anon3 = sub : method { $_[0]->[1] }'; +mytest; +BEGIN {++$ntests} + +eval 'sub e1 ($) : plugh ;'; +mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; +BEGIN {++$ntests} + +eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; +mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; +BEGIN {++$ntests} + +eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; +mytest qr/Unterminated attribute parameter in attribute list at/; +BEGIN {++$ntests} + +eval 'sub e4 ($) : plugh + xyzzy ;'; +mytest qr/Invalid separator character '[+]' in attribute list at/; +BEGIN {++$ntests} + +eval 'my main $x : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my $x : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my $x ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) : ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : plugh;'; +mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; +BEGIN {++$ntests} + +sub A::MODIFY_SCALAR_ATTRIBUTES { return } +eval 'my A $x : plugh;'; +mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; +BEGIN {++$ntests} + +eval 'my A $x : plugh plover;'; +mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; +BEGIN {++$ntests} + +sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } +sub X::foo { 1 } +*Y::bar = \&X::foo; +*Y::bar = \&X::foo; # second time for -w +eval 'package Z; sub Y::bar : locked'; +mytest qr/^X at /; +BEGIN {++$ntests} + +my @attrs = eval 'attributes::get \&Y::bar'; +mytest '', "@attrs", "locked"; +BEGIN {++$ntests} + +@attrs = eval 'attributes::get $anon1'; +mytest '', "@attrs", "locked method"; +BEGIN {++$ntests} + +sub Z::DESTROY { } +sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } +my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; +mytest '', ref($thunk), "Z"; +BEGIN {++$ntests} + +@attrs = eval 'attributes::get $thunk'; +mytest '', "@attrs", "locked method Z"; +BEGIN {++$ntests} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t index 55cc992..cd7c957 100755 --- a/contrib/perl5/t/op/avhv.t +++ b/contrib/perl5/t/op/avhv.t @@ -1,8 +1,8 @@ #!./perl - + BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } require Tie::Array; @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..12\n"; +print "1..28\n"; $sch = { 'abc' => 1, @@ -108,3 +108,71 @@ f($a->{key}); print "not " unless $a->[1] eq 'b'; print "ok 12\n"; +# check if exists() is behaving properly +$avhv = [{foo=>1,bar=>2,pants=>3}]; +print "not " if exists $avhv->{bar}; +print "ok 13\n"; + +$avhv->{pants} = undef; +print "not " unless exists $avhv->{pants}; +print "ok 14\n"; +print "not " if exists $avhv->{bar}; +print "ok 15\n"; + +$avhv->{bar} = 10; +print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; +print "ok 16\n"; + +$v = delete $avhv->{bar}; +print "not " unless $v == 10; +print "ok 17\n"; + +print "not " if exists $avhv->{bar}; +print "ok 18\n"; + +$avhv->{foo} = 'xxx'; +$avhv->{bar} = 'yyy'; +$avhv->{pants} = 'zzz'; +@x = delete @{$avhv}{'foo','pants'}; +print "# @x\nnot " unless "@x" eq "xxx zzz"; +print "ok 19\n"; + +print "not " unless "$avhv->{bar}" eq "yyy"; +print "ok 20\n"; + +# hash assignment +%$avhv = (); +print "not " unless ref($avhv->[0]) eq 'HASH'; +print "ok 21\n"; + +%hv = %$avhv; +print "not " if grep defined, values %hv; +print "ok 22\n"; +print "not " if grep ref, keys %hv; +print "ok 23\n"; + +%$avhv = (foo => 29, pants => 2, bar => 0); +print "not " unless "@$avhv[1..3]" eq '29 0 2'; +print "ok 24\n"; + +my $extra; +my @extra; +($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; +print "ok 25\n"; + +%$avhv = (); +(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; +print "ok 26\n"; + +@extra = qw(whatever and stuff); +%$avhv = (); +(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; +print "ok 27\n"; + +%$avhv = (); +(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; +print "ok 28\n"; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t index b247341..7bcabdf 100755 --- a/contrib/perl5/t/op/bop.t +++ b/contrib/perl5/t/op/bop.t @@ -6,10 +6,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..18\n"; +print "1..30\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -62,3 +62,22 @@ print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n"); # ^ does not truncate print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n"); +# +print "ok \xFF\xFF\n" & "ok 19\n"; +print "ok 20\n" | "ok \0\0\n"; +print "o\000 \0001\000" ^ "\000k\0002\000\n"; + +# +print "ok \x{FF}\x{FF}\n" & "ok 22\n"; +print "ok 23\n" | "ok \x{0}\x{0}\n"; +print "o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n"; + +# +print "ok 25\n" if sprintf("%vd", v4095 & v801) eq 801; +print "ok 26\n" if sprintf("%vd", v4095 | v801) eq 4095; +print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; + +# +print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; +print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; +print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; diff --git a/contrib/perl5/t/op/chars.t b/contrib/perl5/t/op/chars.t new file mode 100755 index 0000000..efdea02 --- /dev/null +++ b/contrib/perl5/t/op/chars.t @@ -0,0 +1,74 @@ +#!./perl + +print "1..33\n"; + +# because of ebcdic.c these should be the same on asciiish +# and ebcdic machines. +# Peter Prymmer <pvhp@best.com>. + +my $c = "\c@"; +print +((ord($c) == 0) ? "" : "not "),"ok 1\n"; +$c = "\cA"; +print +((ord($c) == 1) ? "" : "not "),"ok 2\n"; +$c = "\cB"; +print +((ord($c) == 2) ? "" : "not "),"ok 3\n"; +$c = "\cC"; +print +((ord($c) == 3) ? "" : "not "),"ok 4\n"; +$c = "\cD"; +print +((ord($c) == 4) ? "" : "not "),"ok 5\n"; +$c = "\cE"; +print +((ord($c) == 5) ? "" : "not "),"ok 6\n"; +$c = "\cF"; +print +((ord($c) == 6) ? "" : "not "),"ok 7\n"; +$c = "\cG"; +print +((ord($c) == 7) ? "" : "not "),"ok 8\n"; +$c = "\cH"; +print +((ord($c) == 8) ? "" : "not "),"ok 9\n"; +$c = "\cI"; +print +((ord($c) == 9) ? "" : "not "),"ok 10\n"; +$c = "\cJ"; +print +((ord($c) == 10) ? "" : "not "),"ok 11\n"; +$c = "\cK"; +print +((ord($c) == 11) ? "" : "not "),"ok 12\n"; +$c = "\cL"; +print +((ord($c) == 12) ? "" : "not "),"ok 13\n"; +$c = "\cM"; +print +((ord($c) == 13) ? "" : "not "),"ok 14\n"; +$c = "\cN"; +print +((ord($c) == 14) ? "" : "not "),"ok 15\n"; +$c = "\cO"; +print +((ord($c) == 15) ? "" : "not "),"ok 16\n"; +$c = "\cP"; +print +((ord($c) == 16) ? "" : "not "),"ok 17\n"; +$c = "\cQ"; +print +((ord($c) == 17) ? "" : "not "),"ok 18\n"; +$c = "\cR"; +print +((ord($c) == 18) ? "" : "not "),"ok 19\n"; +$c = "\cS"; +print +((ord($c) == 19) ? "" : "not "),"ok 20\n"; +$c = "\cT"; +print +((ord($c) == 20) ? "" : "not "),"ok 21\n"; +$c = "\cU"; +print +((ord($c) == 21) ? "" : "not "),"ok 22\n"; +$c = "\cV"; +print +((ord($c) == 22) ? "" : "not "),"ok 23\n"; +$c = "\cW"; +print +((ord($c) == 23) ? "" : "not "),"ok 24\n"; +$c = "\cX"; +print +((ord($c) == 24) ? "" : "not "),"ok 25\n"; +$c = "\cY"; +print +((ord($c) == 25) ? "" : "not "),"ok 26\n"; +$c = "\cZ"; +print +((ord($c) == 26) ? "" : "not "),"ok 27\n"; +$c = "\c["; +print +((ord($c) == 27) ? "" : "not "),"ok 28\n"; +$c = "\c\\"; +print +((ord($c) == 28) ? "" : "not "),"ok 29\n"; +$c = "\c]"; +print +((ord($c) == 29) ? "" : "not "),"ok 30\n"; +$c = "\c^"; +print +((ord($c) == 30) ? "" : "not "),"ok 31\n"; +$c = "\c_"; +print +((ord($c) == 31) ? "" : "not "),"ok 32\n"; +$c = "\c?"; +print +((ord($c) == 127) ? "" : "not "),"ok 33\n"; diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t index 77263ad..6723ca3 100755 --- a/contrib/perl5/t/op/chop.t +++ b/contrib/perl5/t/op/chop.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ - -print "1..28\n"; +print "1..30\n"; # optimized @@ -85,3 +83,9 @@ $_ = "axx"; $/ = "yy"; print chomp() == 0 ? "ok 27\n" : "not ok 27\n"; print $_ eq "axx" ? "ok 28\n" : "not ok 28\n"; + +# This case once mistakenly behaved like paragraph mode. +$_ = "ab\n"; +$/ = \3; +print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; +print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t index 95d44f5..c691d6f 100755 --- a/contrib/perl5/t/op/closure.t +++ b/contrib/perl5/t/op/closure.t @@ -7,12 +7,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; -print "1..169\n"; +print "1..171\n"; my $test = 1; sub test (&) { @@ -157,6 +157,31 @@ test { &{$foo[4]}(4) }; +for my $n (0..4) { + $foo[$n] = sub { + # no intervening reference to $n here + sub { $n == $_[0] } + }; +} + +test { + $foo[0]->()->(0) and + $foo[1]->()->(1) and + $foo[2]->()->(2) and + $foo[3]->()->(3) and + $foo[4]->()->(4) +}; + +{ + my $w; + $w = sub { + my ($i) = @_; + test { $i == 10 }; + sub { $w }; + }; + $w->(10); +} + # Additional tests by Tom Phoenix <rootbeer@teleport.com>. { diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t index 33c74ea..9e714a7 100755 --- a/contrib/perl5/t/op/defins.t +++ b/contrib/perl5/t/op/defins.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $SIG{__WARN__} = sub { $warns++; warn $_[0] }; print "1..14\n"; } diff --git a/contrib/perl5/t/op/delete.t b/contrib/perl5/t/op/delete.t index 6cc4475..10a218b 100755 --- a/contrib/perl5/t/op/delete.t +++ b/contrib/perl5/t/op/delete.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ +print "1..36\n"; -print "1..16\n"; +# delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; @@ -13,7 +13,7 @@ $foo{5} = 'e'; $foo = delete $foo{2}; if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} +unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} @@ -24,8 +24,8 @@ if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} @@ -49,3 +49,75 @@ delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; + +{ + my %a = ('bar', 33); + my($a) = \(values %a); + my $b = \$a{bar}; + my $c = \delete $a{bar}; + + print "not " unless $a == $b && $b == $c; + print "ok 17\n"; +} + +# delete() on array elements + +@foo = (); +$foo[1] = 'a'; +$foo[2] = 'b'; +$foo[3] = 'c'; +$foo[4] = 'd'; +$foo[5] = 'e'; + +$foo = delete $foo[2]; + +if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} +unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} +if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} +if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} +if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} +if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} + +@bar = delete @foo[4,5]; + +if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} +if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} +if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} +unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} +unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} +if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} +if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} + +$foo = join('',@foo); +if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} + +if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} + +foreach $key (0 .. $#foo) { + delete $foo[$key]; +} + +if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} + +$foo[0] = 'x'; +$foo[1] = 'y'; + +$foo = "@foo"; +print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; + +$refary[0]->[0] = "FOO"; +$refary[0]->[3] = "BAR"; + +delete $refary[0]->[3]; + +print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; + +{ + my @a = 33; + my($a) = \(@a); + my $b = \$a[0]; + my $c = \delete $a[bar]; + + print "not " unless $a == $b && $b == $c; + print "ok 36\n"; +} diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t index d473ed6..cf4f8b0 100755 --- a/contrib/perl5/t/op/die.t +++ b/contrib/perl5/t/op/die.t @@ -4,7 +4,7 @@ print "1..10\n"; $SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; -$err = "ok 1\n"; +$err = "#[\000]\nok 1\n"; eval { die $err; }; diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index 26b477a..cb0478b 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -7,8 +7,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -e '../lib'; + unshift @INC, '../lib' if -e '../lib'; } + +if ($^O eq 'mpeix') { + print "1..0 # Skip: broken on MPE/iX\n"; + exit 0; +} + my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; use strict; @@ -31,7 +37,7 @@ my %tests = ( 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? - 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'], + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], ); my $max = keys %tests; diff --git a/contrib/perl5/t/op/each.t b/contrib/perl5/t/op/each.t index 9063c2c..879c0d0 100755 --- a/contrib/perl5/t/op/each.t +++ b/contrib/perl5/t/op/each.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $ - -print "1..16\n"; +print "1..19\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -120,3 +118,16 @@ while (($key, $value) = each(h)) { } } if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } + +{ + package Obj; + sub DESTROY { print "ok 18\n"; } + { + my $h = { A => bless [], __PACKAGE__ }; + while (my($k,$v) = each %$h) { + print "ok 17\n" if $k eq 'A' and ref($v) eq 'Obj'; + } + } + print "ok 19\n"; +} + diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t index dc163e9..1838923 100755 --- a/contrib/perl5/t/op/eval.t +++ b/contrib/perl5/t/op/eval.t @@ -1,6 +1,6 @@ #!./perl -print "1..36\n"; +print "1..40\n"; eval 'print "ok 1\n";'; @@ -171,3 +171,38 @@ sub terminal { eval 'print $r' } } $x++; +# Have we cured panic which occurred with require/eval in die handler ? +$SIG{__DIE__} = sub { eval {1}; die shift }; +eval { die "ok ".$x++,"\n" }; +print $@; + +# does scalar eval"" pop stack correctly? +{ + my $c = eval "(1,2)x10"; + print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; + $x++; +} + +# return from eval {} should clear $@ correctly +{ + my $status = eval { + eval { die }; + print "# eval { return } test\n"; + return; # removing this changes behavior + }; + print "not " if $@; + print "ok $x\n"; + $x++; +} + +# ditto for eval "" +{ + my $status = eval q{ + eval q{ die }; + print "# eval q{ return } test\n"; + return; # removing this changes behavior + }; + print "not " if $@; + print "ok $x\n"; + $x++; +} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t index 098a455..23e9ec1 100755 --- a/contrib/perl5/t/op/exec.t +++ b/contrib/perl5/t/op/exec.t @@ -1,13 +1,13 @@ #!./perl -# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $ - $| = 1; # flush stdout +$ENV{LC_ALL} = 'C'; # Forge English error messages. +$ENV{LANGUAGE} = 'C'; # Ditto in GNU. + if ($^O eq 'MSWin32') { - print "# exec is unsupported on Win32\n"; # XXX the system tests could be written to use ./perl and so work on Win32 - print "1..0\n"; + print "1..0 # Skip: shh, win32\n"; exit(0); } @@ -25,10 +25,23 @@ print "not ok 3\n" if system "echo", "ok", "3"; # directly called # these should probably be rewritten to match the examples in perlfunc.pod if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} -if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } -print "ok 5\n"; +if ($^O eq 'mpeix') { + print "ok 5 # skipped: status broken on MPE/iX\n"; +} else { + if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } + print "ok 5\n"; +} -if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";} +$rc = system "lskdfj"; +if ($rc == 255 << 8 or $rc == -1 and + ( + $! == 2 or + $! =~ /\bno\b.*\bfile/i or + $! == 13 or + $! =~ /permission denied/i + ) + ) + {print "ok 6\n";} else {print "not ok 6\n";} unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t new file mode 100755 index 0000000..3363dfd --- /dev/null +++ b/contrib/perl5/t/op/exists_sub.t @@ -0,0 +1,46 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..9\n"; + +sub t1; +sub t2 : locked; +sub t3 (); +sub t4 ($); +sub t5 {1;} +{ + package P1; + sub tmc {1;} + package P2; + @ISA = 'P1'; +} + +print "not " unless exists &t1 && not defined &t1; +print "ok 1\n"; +print "not " unless exists &t2 && not defined &t2; +print "ok 2\n"; +print "not " unless exists &t3 && not defined &t3; +print "ok 3\n"; +print "not " unless exists &t4 && not defined &t4; +print "ok 4\n"; +print "not " unless exists &t5 && defined &t5; +print "ok 5\n"; +P2::->tmc; +print "not " unless not exists &P2::tmc && not defined &P2::tmc; +print "ok 6\n"; +my $ref; +$ref->{A}[0] = \&t4; +print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; +print "ok 7\n"; +undef &P1::tmc; +print "not " unless exists &P1::tmc && not defined &P1::tmc; +print "ok 8\n"; +eval 'exists &t5()'; +print "not " unless $@; +print "ok 9\n"; + +exit 0; diff --git a/contrib/perl5/t/op/fh.t b/contrib/perl5/t/op/fh.t new file mode 100755 index 0000000..86e405a --- /dev/null +++ b/contrib/perl5/t/op/fh.t @@ -0,0 +1,26 @@ +#!./perl + +print "1..5\n"; + +my $test = 0; + +# symbolic filehandles should only result in glob entries with FH constructors + +$|=1; +my $a = "SYM000"; +print "not " if defined(fileno($a)) or defined *{$a}; +++$test; print "ok $test\n"; + +select select $a; +print "not " unless defined *{$a}; +++$test; print "ok $test\n"; + +$a++; +print "not " if close $a or defined *{$a}; +++$test; print "ok $test\n"; + +print "not " unless open($a, ">&STDOUT") and defined *{$a}; +++$test; print $a "ok $test\n"; + +print "not " unless close $a; +++$test; print $a "not "; print "ok $test\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t new file mode 100755 index 0000000..e00d5fb --- /dev/null +++ b/contrib/perl5/t/op/filetest.t @@ -0,0 +1,71 @@ +#!./perl + +# There are few filetest operators that are portable enough to test. +# See pod/perlport.pod for details. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; +} + +use Config; +print "1..10\n"; + +print "not " unless -d 'op'; +print "ok 1\n"; + +print "not " unless -f 'TEST'; +print "ok 2\n"; + +print "not " if -f 'op'; +print "ok 3\n"; + +print "not " if -d 'TEST'; +print "ok 4\n"; + +print "not " unless -r 'TEST'; +print "ok 5\n"; + +# make sure TEST is r-x +eval { chmod 0555, 'TEST' }; +$bad_chmod = $@; + +$oldeuid = $>; # root can read and write anything +eval '$> = 1'; # so switch uid (may not be implemented) + +print "# oldeuid = $oldeuid, euid = $>\n"; + +if (!$Config{d_seteuid}) { + print "ok 6 #skipped, no seteuid\n"; +} +elsif ($bad_chmod) { + print "#[$@]\nok 6 #skipped\n"; +} +else { + print "not " if -w 'TEST'; + print "ok 6\n"; +} + +# Scripts are not -x everywhere so cannot test that. + +eval '$> = $oldeuid'; # switch uid back (may not be implemented) + +# this would fail for the euid 1 +# (unless we have unpacked the source code as uid 1...) +print "not " unless -r 'op'; +print "ok 7\n"; + +# this would fail for the euid 1 +# (unless we have unpacked the source code as uid 1...) +if ($Config{d_seteuid}) { + print "not " unless -w 'op'; + print "ok 8\n"; +} else { + print "ok 8 #skipped, no seteuid\n"; +} + +print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? +print "ok 9\n"; + +print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op"; +print "ok 10\n"; diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t index 9790ff0..80c0b72 100755 --- a/contrib/perl5/t/op/fork.t +++ b/contrib/perl5/t/op/fork.t @@ -1,26 +1,376 @@ #!./perl -# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +# tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { - print "1..0\n"; + unless ($Config{'d_fork'} + or ($^O eq 'MSWin32' and $Config{useithreads} + and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) + { + print "1..0 # Skip: no fork\n"; exit 0; } + $ENV{PERL5LIB} = "../lib"; } -$| = 1; -print "1..2\n"; +if ($^O eq 'mpeix') { + print "1..0 # Skip: fork/status problems on MPE/iX\n"; + exit 0; +} + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "forktmp000"; +1 while -f ++$tmpfile; +END { close TEST; unlink $tmpfile if $tmpfile; } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); + +for (@prgs){ + my $switch; + if (s/^\s*(-\w.*)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + $expected =~ s/\n+$//; + # results can be in any order, so sort 'em + my @expected = sort split /\n/, $expected; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + my $results; + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } + $status = $?; + $results =~ s/\n+$//; + $results =~ s/at\s+forktmp\d+\s+line/at - line/g; + $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + $results =~ s/^\n*Process terminated by SIG\w+\n?//mg + if $^O eq 'os2'; + my @results = sort split /\n/, $results; + if ( "@results" ne "@expected" ) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} +__END__ +$| = 1; if ($cid = fork) { - sleep 2; - if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} + sleep 1; + if ($result = (kill 9, $cid)) { + print "ok 2\n"; + } + else { + print "not ok 2 $result\n"; + } + sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { - $| = 1; print "ok 1\n"; sleep 10; } +EXPECT +ok 1 +ok 2 +######## +$| = 1; +sub forkit { + print "iteration $i start\n"; + my $x = fork; + if (defined $x) { + if ($x) { + print "iteration $i parent\n"; + } + else { + print "iteration $i child\n"; + } + } + else { + print "pid $$ failed to fork\n"; + } +} +while ($i++ < 3) { do { forkit(); }; } +EXPECT +iteration 1 start +iteration 1 parent +iteration 1 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +######## +$| = 1; +fork() + ? (print("parent\n"),sleep(1)) + : (print("child\n"),exit) ; +EXPECT +parent +child +######## +$| = 1; +fork() + ? (print("parent\n"),exit) + : (print("child\n"),sleep(1)) ; +EXPECT +parent +child +######## +$| = 1; +@a = (1..3); +for (@a) { + if (fork) { + print "parent $_\n"; + $_ = "[$_]"; + } + else { + print "child $_\n"; + $_ = "-$_-"; + } +} +print "@a\n"; +EXPECT +parent 1 +child 1 +parent 2 +child 2 +parent 2 +child 2 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +[1] [2] [3] +-1- [2] [3] +[1] -2- [3] +[1] [2] -3- +-1- -2- [3] +-1- [2] -3- +[1] -2- -3- +-1- -2- -3- +######## +use Config; +$| = 1; +$\ = "\n"; +fork() + ? print($Config{osname} eq $^O) + : print($Config{osname} eq $^O) ; +EXPECT +1 +1 +######## +$| = 1; +$\ = "\n"; +fork() + ? do { require Config; print($Config::Config{osname} eq $^O); } + : do { require Config; print($Config::Config{osname} eq $^O); } +EXPECT +1 +1 +######## +$| = 1; +use Cwd; +$\ = "\n"; +my $dir; +if (fork) { + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; + chdir ".."; + rmdir $dir; +} +else { + sleep 2; + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; + chdir ".."; + rmdir $dir; +} +EXPECT +ok 1 parent +ok 1 child +######## +$| = 1; +$\ = "\n"; +my $getenv; +if ($^O eq 'MSWin32') { + $getenv = qq[$^X -e "print \$ENV{TST}"]; +} +else { + $getenv = qq[$^X -e 'print \$ENV{TST}']; +} +$ENV{TST} = 'foo'; +if (fork) { + sleep 1; + print "parent before: " . `$getenv`; + $ENV{TST} = 'bar'; + print "parent after: " . `$getenv`; +} +else { + print "child before: " . `$getenv`; + $ENV{TST} = 'baz'; + print "child after: " . `$getenv`; +} +EXPECT +child before: foo +child after: baz +parent before: foo +parent after: bar +######## +$| = 1; +$\ = "\n"; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exit(42); +} +EXPECT +parent got 10752 +######## +$| = 1; +$\ = "\n"; +my $echo = 'echo'; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exec("$echo foo"); +} +EXPECT +foo +parent got 0 +######## +if (fork) { + die "parent died"; +} +else { + die "child died"; +} +EXPECT +parent died at - line 2. +child died at - line 5. +######## +if ($pid = fork) { + eval { die "parent died" }; + print $@; +} +else { + eval { die "child died" }; + print $@; +} +EXPECT +parent died at - line 2. +child died at - line 6. +######## +if (eval q{$pid = fork}) { + eval q{ die "parent died" }; + print $@; +} +else { + eval q{ die "child died" }; + print $@; +} +EXPECT +parent died at (eval 2) line 1. +child died at (eval 2) line 1. +######## +BEGIN { + $| = 1; + fork and exit; + print "inner\n"; +} +# XXX In emulated fork(), the child will not execute anything after +# the BEGIN block, due to difficulties in recreating the parse stacks +# and restarting yyparse() midstream in the child. This can potentially +# be overcome by treating what's after the BEGIN{} as a brand new parse. +#print "outer\n" +EXPECT +inner +######## +sub pipe_to_fork ($$) { + my $parent = shift; + my $child = shift; + pipe($child, $parent) or die; + my $pid = fork(); + die "fork() failed: $!" unless defined $pid; + close($pid ? $child : $parent); + $pid; +} + +if (pipe_to_fork('PARENT','CHILD')) { + # parent + print PARENT "pipe_to_fork\n"; + close PARENT; +} +else { + # child + while (<CHILD>) { print; } + close CHILD; + exit; +} + +sub pipe_from_fork ($$) { + my $parent = shift; + my $child = shift; + pipe($parent, $child) or die; + my $pid = fork(); + die "fork() failed: $!" unless defined $pid; + close($pid ? $child : $parent); + $pid; +} + +if (pipe_from_fork('PARENT','CHILD')) { + # parent + while (<PARENT>) { print; } + close PARENT; +} +else { + # child + print CHILD "pipe_from_fork\n"; + close CHILD; + exit; +} +EXPECT +pipe_from_fork +pipe_to_fork diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t index 253e4a3..4c27445 100755 --- a/contrib/perl5/t/op/glob.t +++ b/contrib/perl5/t/op/glob.t @@ -1,6 +1,9 @@ #!./perl -# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} print "1..6\n"; diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t index 8096aff..96bb8dd 100755 --- a/contrib/perl5/t/op/goto.t +++ b/contrib/perl5/t/op/goto.t @@ -2,7 +2,7 @@ # "This IS structured code. It's just randomly structured." -print "1..13\n"; +print "1..16\n"; while ($?) { $foo = 1; @@ -30,8 +30,8 @@ print "#2\t:$foo: == 4\n"; if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$x = `$PERL -e "goto foo;" 2>&1`; -if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; } +$CMD = qq[$PERL -e "goto foo;" 2>&1 ]; +$x = `$CMD`; if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} @@ -55,6 +55,27 @@ exit; FINALE: print "ok 13\n"; + +# does goto LABEL handle block contexts correctly? + +my $cond = 1; +for (1) { + if ($cond == 1) { + $cond = 0; + goto OTHER; + } + elsif ($cond == 0) { + OTHER: + $cond = 2; + print "ok 14\n"; + goto THIRD; + } + else { + THIRD: + print "ok 15\n"; + } +} +print "ok 16\n"; exit; bypass: diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t index a35575e..8d9bca1 100755 --- a/contrib/perl5/t/op/goto_xs.t +++ b/contrib/perl5/t/op/goto_xs.t @@ -10,7 +10,7 @@ # break correctly as well. chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; # turn warnings into fatal errors diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t new file mode 100755 index 0000000..761d8b9 --- /dev/null +++ b/contrib/perl5/t/op/grent.t @@ -0,0 +1,139 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib" if -d "../lib"; + eval {my @n = getgrgid 0}; + if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { + print "1..0 # Skip: $1\n"; + exit 0; + } + eval { require Config; import Config; }; + my $reason; + if ($Config{'i_grp'} ne 'define') { + $reason = '$Config{i_grp} not defined'; + } + elsif (not -f "/etc/group" ) { # Play safe. + $reason = 'no /etc/group file'; + } + + if (not defined $where) { # Try NIS. + foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { + if (-x $ypcat && + open(GR, "$ypcat group 2>/dev/null |") && + defined(<GR>)) { + $where = "NIS group"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try NetInfo. + foreach my $nidump (qw(/usr/bin/nidump)) { + if (-x $nidump && + open(GR, "$nidump group . 2>/dev/null |") && + defined(<GR>)) { + $where = "NetInfo group"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try local. + my $GR = "/etc/group"; + if (-f $GR && open(GR, $GR) && defined(<GR>)) { + undef $reason; + $where = $GR; + } + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } +} + +# By now GR filehandle should be open and full of juicy group entries. + +print "1..1\n"; + +# Go through at most this many groups. +# (note that the first entry has been read away by now) +my $max = 25; + +my $n = 0; +my $tst = 1; +my %perfect; +my %seen; + +while (<GR>) { + chomp; + my @s = split /:/; + my ($name_s,$passwd_s,$gid_s,$members_s) = @s; + if (@s) { + push @{ $seen{$name_s} }, $.; + } else { + warn "# Your $where line $. is empty.\n"; + next; + } + if ($n == $max) { + local $/; + my $junk = <GR>; + last; + } + # In principle we could whine if @s != 4 but do we know enough + # of group file formats everywhere? + if (@s == 4) { + $members_s =~ s/\s*,\s*/,/g; + $members_s =~ s/\s+$//; + $members_s =~ s/^\s+//; + @n = getgrgid($gid_s); + # 'nogroup' et al. + next unless @n; + my ($name,$passwd,$gid,$members) = @n; + # Protect against one-to-many and many-to-one mappings. + if ($name_s ne $name) { + @n = getgrnam($name_s); + ($name,$passwd,$gid,$members) = @n; + next if $name_s ne $name; + } + # NOTE: group names *CAN* contain whitespace. + $members =~ s/\s+/,/g; + # what about different orders of members? + $perfect{$name_s}++ + if $name eq $name_s and +# Do not compare passwords: think shadow passwords. +# Not that group passwords are used much but better not assume anything. + $gid eq $gid_s and + $members eq $members_s; + } + $n++; +} + +if (keys %perfect == 0) { + $max++; + print <<EOEX; +# +# The failure of op/grent test is not necessarily serious. +# It may fail due to local group administration conventions. +# If you are for example using both NIS and local groups, +# test failure is possible. Any distributed group scheme +# can cause such failures. +# +# What the grent test is doing is that it compares the $max first +# entries of $where +# with the results of getgrgid() and getgrnam() call. If it finds no +# matches at all, it suspects something is wrong. +# +EOEX + print "not "; + $not = 1; +} else { + $not = 0; +} +print "ok ", $tst++; +print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; +print "\n"; + +close(GR); diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t index 45d0e25..3a7f8ad 100755 --- a/contrib/perl5/t/op/grep.t +++ b/contrib/perl5/t/op/grep.t @@ -4,7 +4,7 @@ # grep() and map() tests # -print "1..3\n"; +print "1..27\n"; $test = 1; @@ -29,3 +29,71 @@ sub ok { $test++; } +{ + print map({$_} ("ok $test\n")); + $test++; + print map + ({$_} ("ok $test\n")); + $test++; + print((map({a => $_}, ("ok $test\n")))[0]->{a}); + $test++; + print((map + ({a=>$_}, + ("ok $test\n")))[0]->{a}); + $test++; + print map { $_ } ("ok $test\n"); + $test++; + print map + { $_ } ("ok $test\n"); + $test++; + print((map {a => $_}, ("ok $test\n"))[0]->{a}); + $test++; + print((map + {a=>$_}, + ("ok $test\n"))[0]->{a}); + $test++; + my $x = "ok \xFF\xFF\n"; + print map($_&$x,("ok $test\n")); + $test++; + print map + ($_ & $x, ("ok $test\n")); + $test++; + print map { $_ & $x } ("ok $test\n"); + $test++; + print map + { $_&$x } ("ok $test\n"); + $test++; + + print grep({$_} ("ok $test\n")); + $test++; + print grep + ({$_} ("ok $test\n")); + $test++; + print grep({a => $_}->{a}, ("ok $test\n")); + $test++; + print grep + ({a => $_}->{a}, + ("ok $test\n")); + $test++; + print grep { $_ } ("ok $test\n"); + $test++; + print grep + { $_ } ("ok $test\n"); + $test++; + print grep {a => $_}->{a}, ("ok $test\n"); + $test++; + print grep + {a => $_}->{a}, + ("ok $test\n"); + $test++; + print grep($_&"X",("ok $test\n")); + $test++; + print grep + ($_&"X", ("ok $test\n")); + $test++; + print grep { $_ & "X" } ("ok $test\n"); + $test++; + print grep + { $_ & "X" } ("ok $test\n"); + $test++; +} diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t index 47aabe3..4b655c8 100755 --- a/contrib/perl5/t/op/groups.t +++ b/contrib/perl5/t/op/groups.t @@ -1,13 +1,101 @@ #!./perl -if (! -x ($groups = '/usr/ucb/groups') && - ! -x ($groups = '/usr/bin/groups') && - ! -x ($groups = '/bin/groups') -) { - print "1..0\n"; +$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . + exists $ENV{PATH} ? ":$ENV{PATH}" : ""; +$ENV{LC_ALL} = "C"; # so that external utilities speak English +$ENV{LANGUAGE} = 'C'; # GNU locale extension + +sub quit { + print "1..0 # Skip: no `id` or `groups`\n"; exit 0; } +quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i; + +# We have to find a command that prints all (effective +# and real) group names (not ids). The known commands are: +# groups +# id -Gn +# id -a +# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. +# Beware 2: id -Gn or id -a format might be id(name) or name(id). +# Beware 3: the groups= might be anywhere in the id output. +# Beware 4: groups can have spaces ('id -a' being the only defense against this) +# Beware 5: id -a might not contain the groups= part. +# +# That is, we might meet the following: +# +# foo bar zot # accept +# foo 22 42 bar zot # accept +# 1 22 42 2 3 # reject +# groups=(42),foo(1),bar(2),zot me(3) # parse +# groups=22,42,1(foo),2(bar),3(zot me) # parse +# +# and the groups= might be after, before, or between uid=... and gid=... + +GROUPS: { + # prefer 'id' over 'groups' (is this ever wrong anywhere?) + # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) + if (($groups = `id -a 2>/dev/null`) ne '') { + # $groups is of the form: + # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) + last GROUPS if $groups =~ /groups=/; + } + if (($groups = `id -Gn 2>/dev/null`) ne '') { + # $groups could be of the form: + # users 33536 39181 root dev + last GROUPS if $groups !~ /^(\d|\s)+$/; + } + if (($groups = `groups 2>/dev/null`) ne '') { + # may not reflect all groups in some places, so do a sanity check + if (-d '/afs') { + print <<EOM; +# These test results *may* be bogus, as you appear to have AFS, +# and I can't find a working 'id' in your PATH (which I have set +# to '$ENV{PATH}'). +# +# If these tests fail, report the particular incantation you use +# on this platform to find *all* the groups that an arbitrary +# luser may belong to, using the 'perlbug' program. +EOM + } + last GROUPS; + } + # Okay, not today. + quit(); +} + +unless (eval { getgrgid(0); 1 }) { + print "1..0 # Skip: getgrgid() not implemented\n"; + exit 0; +} + +# Remember that group names can contain whitespace, '-', et cetera. +# That is: do not \w, do not \S. +if ($groups =~ /groups=(.+)( [ug]id=|$)/) { + my $gr = $1; + my @g0 = split /,/, $gr; + my @g1; + # prefer names over numbers + for (@g0) { + # 42(zot me) + if (/^(\d+)(?:\(([^)]+)\))?/) { + push @g1, ($2 || $1); + } + # zot me(42) + elsif (/^([^(]*)\((\d+)\)/) { + push @g1, ($1 || $2); + } + else { + print "# ignoring group entry [$_]\n"; + } + } + print "# groups=$gr\n"; + print "# g0 = @g0\n"; + print "# g1 = @g1\n"; + $groups = "@g1"; +} + print "1..2\n"; $pwgid = $( + 0; @@ -27,9 +115,13 @@ for (split(' ', $()) { } } -$gr1 = join(' ', sort @gr); +if ($^O eq "uwin") { # Or anybody else who can have spaces in group names. + $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); +} else { + $gr1 = join(' ', sort @gr); +} -$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`$groups`))); +$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); if ($gr1 eq $gr2) { print "ok 1\n"; diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t index c253e4b..04905cd 100755 --- a/contrib/perl5/t/op/gv.t +++ b/contrib/perl5/t/op/gv.t @@ -4,7 +4,14 @@ # various typeglob tests # -print "1..23\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use warnings; + +print "1..30\n"; # type coersion on assignment $foo = 'foo'; @@ -62,7 +69,7 @@ if (defined $baa) { # fact that %X::Y:: is stored in %X:: isn't documented. # (I hope.) -{ package Foo::Bar } +{ package Foo::Bar; no warnings 'once'; $test=1; } print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; @@ -77,7 +84,7 @@ print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; { my $msg; local $SIG{__WARN__} = sub { $msg = $_[0] }; - local $^W = 1; + use warnings; *foo = 'bar'; print $msg ? "not ok" : "ok", " 15\n"; *foo = undef; @@ -95,4 +102,39 @@ print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n"; print {*x{IO}} "ok 22\n"; print {*x{FILEHANDLE}} "ok 23\n"; +# test if defined() doesn't create any new symbols + +{ + my $test = 23; + + my $a = "SYM000"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined @{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined %{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined ${$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined &{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + *{$a} = sub { print "ok $test\n" }; + print "not " unless defined &{$a} and defined *{$a}; + ++$test; &{$a}; +} + +# does pp_readline() handle glob-ness correctly? + +{ + my $g = *foo; + $g = <DATA>; + print $g; +} +__END__ +ok 30 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t index 6343a2a..9182273 100755 --- a/contrib/perl5/t/op/hashwarn.t +++ b/contrib/perl5/t/op/hashwarn.t @@ -2,19 +2,18 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; +use warnings; use vars qw{ @warnings }; BEGIN { - $^W |= 1; # Insist upon warnings - # ...and save 'em as we go $SIG{'__WARN__'} = sub { push @warnings, @_ }; $| = 1; - print "1..7\n"; + print "1..9\n"; } END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings } @@ -66,6 +65,13 @@ my $ref_msg = '/^Reference found where even-sized list expected/'; %hash = sub { print "ok" }; test_warning 6, shift @warnings, $odd_msg; + my $avhv = [{x=>1,y=>2}]; + %$avhv = (x=>13,'y'); + test_warning 7, shift @warnings, $odd_msg; + + %$avhv = 'x'; + test_warning 8, shift @warnings, $odd_msg; + $_ = { 1..10 }; - test 7, ! @warnings, "Unexpected warning"; + test 9, ! @warnings, "Unexpected warning"; } diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t index e5a2a92..f59115e 100755 --- a/contrib/perl5/t/op/inc.t +++ b/contrib/perl5/t/op/inc.t @@ -1,9 +1,6 @@ #!./perl - -# $RCSfile$ - -print "1..6\n"; +print "1..12\n"; # Verify that addition/subtraction properly upgrade to doubles. # These tests are only significant on machines with 32 bit longs, @@ -50,3 +47,51 @@ if ($a == -2147483649) {print "ok 6\n"} else {print "not ok 6\n";} + +$a = 2147483648; +$a = -$a; +$c=$a--; +if ($a == -2147483649) + {print "ok 7\n"} +else + {print "not ok 7\n";} + +$a = 2147483648; +$a = -$a; +$c=--$a; +if ($a == -2147483649) + {print "ok 8\n"} +else + {print "not ok 8\n";} + +$a = 2147483648; +$a = -$a; +$a=$a-1; +if ($a == -2147483649) + {print "ok 9\n"} +else + {print "not ok 9\n";} + +$a = 2147483648; +$b = -$a; +$c=$b--; +if ($b == -$a-1) + {print "ok 10\n"} +else + {print "not ok 10\n";} + +$a = 2147483648; +$b = -$a; +$c=--$b; +if ($b == -$a-1) + {print "ok 11\n"} +else + {print "not ok 11\n";} + +$a = 2147483648; +$b = -$a; +$b=$b-1; +if ($b == -(++$a)) + {print "ok 12\n"} +else + {print "not ok 12\n";} diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t index eb060ac..6ac0866 100755 --- a/contrib/perl5/t/op/int.t +++ b/contrib/perl5/t/op/int.t @@ -1,8 +1,11 @@ #!./perl -# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -print "1..4\n"; +print "1..6\n"; # compile time evaluation @@ -15,3 +18,13 @@ if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} $x = 1.234; if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} + +$x = length("abc") % -10; +print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; + +{ + use integer; + $x = length("abc") % -10; + $y = (3/-10)*-10; + print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; +} diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t index eec4611..def5a9e 100755 --- a/contrib/perl5/t/op/join.t +++ b/contrib/perl5/t/op/join.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $ - -print "1..3\n"; +print "1..6\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} @@ -10,3 +8,15 @@ if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} + +my $f = 'a'; +$f = join ',', 'b', $f, 'e'; +if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";} + +$f = 'a'; +$f = join ',', $f, 'b', 'e'; +if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} + +$f = 'a'; +$f = join $f, 'b', 'e', 'k'; +if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t new file mode 100755 index 0000000..2fb059d --- /dev/null +++ b/contrib/perl5/t/op/lex_assign.t @@ -0,0 +1,324 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +umask 0; +$xref = \ ""; +$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X; +@a = (1..5); +%h = (1..6); +$aref = \@a; +$href = \%h; +open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; +$chopit = 'aaaaaa'; +@chopar = (113 .. 119); +$posstr = '123456'; +$cstr = 'aBcD.eF'; +pos $posstr = 3; +$nn = $n = 2; +sub subb {"in s"} + +@INPUT = <DATA>; +@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; +print "1..", (10 + @INPUT + @simple_input), "\n"; +$ord = 0; + +sub wrn {"@_"} + +# Check correct optimization of ucfirst etc +$ord++; +my $a = "AB"; +my $b = "\u\L$a"; +print "not " unless $b eq 'Ab'; +print "ok $ord\n"; + +# Check correct destruction of objects: +my $dc = 0; +sub A::DESTROY {$dc += 1} +$a=8; +my $b; +{ my $c = 6; $b = bless \$c, "A"} + +$ord++; +print "not " unless $dc == 0; +print "ok $ord\n"; + +$b = $a+5; + +$ord++; +print "not " unless $dc == 1; +print "ok $ord\n"; + +$ord++; +my $xxx = 'b'; +$xxx = 'c' . ($xxx || 'e'); +print "not " unless $xxx eq 'cb'; +print "ok $ord\n"; + +{ # Check calling STORE + my $sc = 0; + sub B::TIESCALAR {bless [11], 'B'} + sub B::FETCH { -(shift->[0]) } + sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift } + + my $m; + tie $m, 'B'; + $m = 100; + + $ord++; + print "not " unless $sc == 1; + print "ok $ord\n"; + + my $t = 11; + $m = $t + 89; + + $ord++; + print "not " unless $sc == 2; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == -117; + print "ok $ord\n"; + + $m += $t; + + $ord++; + print "not " unless $sc == 3; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == 89; + print "ok $ord\n"; + +} + +# Chains of assignments + +my ($l1, $l2, $l3, $l4); +my $zzzz = 12; +$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; + +$ord++; +print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " + unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 + and $l2 == 13 and $l3 == 13 and $l4 == 13; +print "ok $ord\n"; + +for (@INPUT) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + $op = "$op==$op" unless $op =~ /==/; + ($op, $expectop) = $op =~ /(.*)==(.*)/; + + $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) + ? "skip" : "not"; + $integer = ($comment =~ /^i_/) ? "use integer" : '' ; + (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; + + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$a = 'fake'; + $integer; + \$a = $op; + \$b = $expectop; + if (\$a ne \$b) { + print "# \$comment: got `\$a', expected `\$b'\n"; + print "\$skip " if \$a ne \$b or \$skip eq 'skip'; + } + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} + +for (@simple_input) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$$variable = "Ac# Ca\\nxxx"; + \$$variable = $operator \$$variable; + \$toself = \$$variable; + \$direct = $operator "Ac# Ca\\nxxx"; + print "# \\\$$variable = $operator \\\$$variable\\nnot " + unless \$toself eq \$direct; + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } elsif ($@ =~ /Can't (modify|take log of 0)/) { + print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} +__END__ +ref $xref # ref +ref $cstr # ref nonref +`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$undefed` # backtick undef skip(MSWin32) +<*> # glob +<OP> # readline +'faked' # rcatline +(@z = (1 .. 3)) # aassign +chop $chopit # chop +(chop (@x=@chopar)) # schop +chomp $chopit # chomp +(chop (@x=@chopar)) # schomp +pos $posstr # pos +pos $chopit # pos returns undef +$nn++==2 # postinc +$nn++==3 # i_postinc +$nn--==4 # postdec +$nn--==3 # i_postdec +$n ** $n # pow +$n * $n # multiply +$n * $n # i_multiply +$n / $n # divide +$n / $n # i_divide +$n % $n # modulo +$n % $n # i_modulo +$n x $n # repeat +$n + $n # add +$n + $n # i_add +$n - $n # subtract +$n - $n # i_subtract +$n . $n # concat +$n . $a=='2fake' # concat with self +"3$a"=='3fake' # concat with self in stringify +"$n" # stringify +$n << $n # left_shift +$n >> $n # right_shift +$n <=> $n # ncmp +$n <=> $n # i_ncmp +$n cmp $n # scmp +$n & $n # bit_and +$n ^ $n # bit_xor +$n | $n # bit_or +-$n # negate +-$n # i_negate +~$n # complement +atan2 $n,$n # atan2 +sin $n # sin +cos $n # cos +'???' # rand +exp $n # exp +log $n # log +sqrt $n # sqrt +int $n # int +hex $n # hex +oct $n # oct +abs $n # abs +length $posstr # length +substr $posstr, 2, 2 # substr +vec("abc",2,8) # vec +index $posstr, 2 # index +rindex $posstr, 2 # rindex +sprintf "%i%i", $n, $n # sprintf +ord $n # ord +chr $n # chr +crypt $n, $n # crypt +ucfirst ($cstr . "a") # ucfirst padtmp +ucfirst $cstr # ucfirst +lcfirst $cstr # lcfirst +uc $cstr # uc +lc $cstr # lc +quotemeta $cstr # quotemeta +@$aref # rv2av +@$undefed # rv2av undef +each %h==1 # each +values %h # values +keys %h # keys +%$href # rv2hv +pack "C2", $n,$n # pack +split /a/, "abad" # split +join "a"; @a # join +push @a,3==6 # push +unshift @aaa # unshift +reverse @a # reverse +reverse $cstr # reverse - scal +grep $_, 1,0,2,0,3 # grepwhile +map "x$_", 1,0,2,0,3 # mapwhile +subb() # entersub +caller # caller +warn "ignore this\n" # warn +'faked' # die +open BLAH, "<non-existent" # open +fileno STDERR # fileno +umask 0 # umask +select STDOUT # sselect +select "","","",0 # select +getc OP # getc +'???' # read +'???' # sysread +'???' # syswrite +'???' # send +'???' # recv +'???' # tell +'???' # fcntl +'???' # ioctl +'???' # flock +'???' # accept +'???' # shutdown +'???' # ftsize +'???' # ftmtime +'???' # ftatime +'???' # ftctime +chdir 'non-existent' # chdir +'???' # chown +'???' # chroot +unlink 'non-existent' # unlink +chmod 'non-existent' # chmod +utime 'non-existent' # utime +rename 'non-existent', 'non-existent1' # rename +link 'non-existent', 'non-existent1' # link +'???' # symlink +readlink 'non-existent', 'non-existent1' # readlink +'???' # mkdir +'???' # rmdir +'???' # telldir +'???' # fork +'???' # wait +'???' # waitpid +system "$runme -e 0" # system skip(VMS) +'???' # exec +'???' # kill +getppid # getppid +getpgrp # getpgrp +'???' # setpgrp +getpriority $$, $$ # getpriority +'???' # setpriority +time # time +localtime $^T # localtime +gmtime $^T # gmtime +sleep 1 # sleep +'???' # alarm +'???' # shmget +'???' # shmctl +'???' # shmread +'???' # shmwrite +'???' # msgget +'???' # msgctl +'???' # msgsnd +'???' # msgrcv +'???' # semget +'???' # semctl +'???' # semop +'???' # getlogin +'???' # syscall diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t new file mode 100755 index 0000000..e704f6f --- /dev/null +++ b/contrib/perl5/t/op/lfs.t @@ -0,0 +1,226 @@ +# NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio). +# sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. +# If you modify/add tests here, remember to update also t/lib/syslfs.t. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + # Don't bother if there are no quad offsets. + require Config; import Config; + if ($Config{lseeksize} < 8) { + print "1..0\n# no 64-bit file offsets\n"; + exit(0); + } +} + +sub zap { + close(BIG); + unlink("big"); + unlink("big1"); + unlink("big2"); +} + +sub bye { + zap(); + exit(0); +} + +sub explain { + 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.) +# +# Perl may still be able to support large files, once you have +# such a process, enough quota, and such a (file) system. +# +EOM +} + +print "# checking whether we have sparse files...\n"; + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files (because this is $^O) \n"; + bye(); +} + +# Known haves that have problems running this test +# (for example because they do not support sparse files, like UNICOS) +if ($^O eq 'unicos') { + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + bye(); +} + +# Then try to heuristically deduce whether we have sparse files. + +# Let's not depend on Fcntl or any other extension. + +my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); + +# We'll start off by creating a one megabyte file which has +# only three "true" bytes. If we have sparseness, we should +# consume less blocks than one megabyte (assuming nobody has +# one megabyte blocks...) + +open(BIG, ">big1") or + do { warn "open big1 failed: $!\n"; bye }; +binmode(BIG) or + do { warn "binmode big1 failed: $!\n"; bye }; +seek(BIG, 1_000_000, $SEEK_SET) or + do { warn "seek big1 failed: $!\n"; bye }; +print BIG "big" or + do { warn "print big1 failed: $!\n"; bye }; +close(BIG) or + do { warn "close big1 failed: $!\n"; bye }; + +my @s1 = stat("big1"); + +print "# s1 = @s1\n"; + +open(BIG, ">big2") or + do { warn "open big2 failed: $!\n"; bye }; +binmode(BIG) or + do { warn "binmode big2 failed: $!\n"; bye }; +seek(BIG, 2_000_000, $SEEK_SET) or + do { warn "seek big2 failed; $!\n"; bye }; +print BIG "big" or + do { warn "print big2 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big2 failed; $!\n"; bye }; + +my @s2 = stat("big2"); + +print "# s2 = @s2\n"; + +zap(); + +unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && + $s1[11] == $s2[11] && $s1[12] == $s2[12]) { + print "1..0\n#no sparse files?\n"; + bye; +} + +print "# we seem to have sparse files...\n"; + +# By now we better be sure that we do have sparse files: +# if we are not, the following will hog 5 gigabytes of disk. Ooops. + +$ENV{LC_ALL} = "C"; + +open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; +unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { + print "1..0\n# seeking past 2GB failed: $!\n"; + explain(); + bye(); +} + +# Either the print or (more likely, thanks to buffering) the close will +# fail if there are are filesize limitations (process or fs). +my $print = print BIG "big"; +print "# print failed: $!\n" unless $print; +my $close = close BIG; +print "# close failed: $!\n" unless $close; +unless ($print && $close) { + if ($! =~/too large/i) { + print "1..0\n# writing past 2GB failed: process limits?\n"; + } elsif ($! =~ /quota/i) { + print "1..0\n# filesystem quota limits?\n"; + } + explain(); + bye(); +} + +@s = stat("big"); + +print "# @s\n"; + +unless ($s[7] == 5_000_000_003) { + print "1..0\n# not configured to use large files?\n"; + explain(); + bye(); +} + +sub fail () { + print "not "; + $fail++; +} + +print "1..17\n"; + +my $fail = 0; + +fail unless $s[7] == 5_000_000_003; # exercizes pp_stat +print "ok 1\n"; + +fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize +print "ok 2\n"; + +fail unless -e "big"; +print "ok 3\n"; + +fail unless -f "big"; +print "ok 4\n"; + +open(BIG, "big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; + +fail unless seek(BIG, 4_500_000_000, $SEEK_SET); +print "ok 5\n"; + +fail unless 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; +print "ok 8\n"; + +fail unless seek(BIG, -1, $SEEK_CUR); +print "ok 9\n"; + +fail unless 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; +print "ok 12\n"; + +my $big; + +fail unless read(BIG, $big, 3) == 3; +print "ok 13\n"; + +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); +print "ok 15\n"; + +my $zero; + +fail unless read(BIG, $zero, 3) == 3; +print "ok 16\n"; + +fail unless $zero eq "\0\0\0"; +print "ok 17\n"; + +explain if $fail; + +bye(); # does the necessary cleanup + +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + +# eof diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t index a4230b6..4d7a2d5 100755 --- a/contrib/perl5/t/op/list.t +++ b/contrib/perl5/t/op/list.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $ - -print "1..27\n"; +print "1..28\n"; @foo = (1, 2, 3, 4); if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} @@ -81,3 +79,11 @@ for ($x = 0; $x < 3; $x++) { print $a,$b,$c; } +# slices +{ + my @a = (0, undef, undef, 3); + my @b = @a[1,2]; + my @c = (0, undef, undef, 3)[1, 2]; + print "not " unless @b == @c and @c == 2; + print "ok 28\n"; +} diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t new file mode 100755 index 0000000..f15201f --- /dev/null +++ b/contrib/perl5/t/op/lop.t @@ -0,0 +1,44 @@ +#!./perl + +# +# test the logical operators '&&', '||', '!', 'and', 'or', 'not' +# + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..7\n"; + +my $test = 0; +for my $i (undef, 0 .. 2, "", "0 but true") { + my $true = 1; + my $false = 0; + for my $j (undef, 0 .. 2, "", "0 but true") { + $true &&= !( + ((!$i || !$j) != !($i && $j)) + or (!($i || $j) != (!$i && !$j)) + or (!!($i || $j) != !(!$i && !$j)) + or (!(!$i || !$j) != !!($i && $j)) + ); + $false ||= ( + ((!$i || !$j) == !!($i && $j)) + and (!!($i || $j) == (!$i && !$j)) + and ((!$i || $j) == ($i && !$j)) + and (($i || !$j) != (!$i && $j)) + ); + } + if (not $true) { + print "not "; + } elsif ($false) { + print "not "; + } + print "ok ", ++$test, "\n"; +} + +# $test == 6 +my $i = 0; +(($i ||= 1) &&= 3) += 4; +print "not " unless $i == 7; +print "ok ", ++$test, "\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t index 7f08e06..7739276 100755 --- a/contrib/perl5/t/op/magic.t +++ b/contrib/perl5/t/op/magic.t @@ -1,13 +1,14 @@ #!./perl BEGIN { - $^W = 1; $| = 1; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } +use warnings; + sub ok { my ($n, $result, $info) = @_; if ($result) { @@ -22,6 +23,8 @@ sub ok { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; +$Is_os2 = $^O eq 'os2'; +$Is_Cygwin = $^O eq 'cygwin'; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); print "1..35\n"; @@ -111,6 +114,14 @@ ok 18, $$ > 0, $$; if ($^O eq 'qnx') { chomp($wd = `/usr/bin/fullpath -t`); } + elsif($Is_Cygwin) { + # Cygwin turns the symlink into the real file + chomp($wd = `pwd`); + $wd =~ s#/t$##; + } + elsif($Is_os2) { + $wd = Cwd::sys_cwd(); + } else { $wd = '.'; } @@ -120,8 +131,9 @@ ok 18, $$ > 0, $$; $script = "$wd/show-shebang"; if ($Is_MSWin32) { chomp($wd = `cd`); - $perl = "$wd\\perl.exe"; - $script = "$wd\\show-shebang.bat"; + $wd =~ s|\\|/|g; + $perl = "$wd/perl.exe"; + $script = "$wd/show-shebang.bat"; $headmaybe = <<EOH ; \@rem =' \@echo off @@ -135,13 +147,16 @@ __END__ :endofperl EOT } - if ($^O eq 'os390') { # no shebang + elsif ($Is_os2) { + $script = "./show-shebang"; + } + if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang $headmaybe = <<EOH ; eval 'exec ./perl -S \$0 \${1+"\$\@"}' if 0; EOH } - $s1 = $s2 = "\$^X is $perl, \$0 is $script\n"; + $s1 = "\$^X is $perl, \$0 is $script\n"; ok 19, open(SCRIPT, ">$script"), $!; ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; #!$wd/perl @@ -151,13 +166,15 @@ EOF ok 21, close(SCRIPT), $!; ok 22, chmod(0755, $script), $!; $_ = `$script`; - s/.exe//i if $Is_Dos; + s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl s{is perl}{is $perl}; # for systems where $^X is only a basename - ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:"; + s{\\}{/}g; + ok 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:"; $_ = `$perl $script`; - s/.exe//i if $Is_Dos; - ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`"; + s/\.exe//i if $Is_Dos or $Is_os2; + s{\\}{/}g; + ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`"; ok 25, unlink($script), $!; } @@ -185,7 +202,7 @@ else { } { - local $SIG{'__WARN__'} = sub { print "not " }; + local $SIG{'__WARN__'} = sub { print "# @_\nnot " }; $! = undef; print "ok 31\n"; } @@ -202,8 +219,8 @@ if ($Is_MSWin32) { ok 35, (scalar(keys(%ENV)) == 0); } else { - ok "32 # skipped",1; - ok "33 # skipped",1; - ok "34 # skipped",1; - ok "35 # skipped",1; + ok "32 # skipped: no caseless %ENV support",1; + ok "33 # skipped: no caseless %ENV support",1; + ok "34 # skipped: no caseless %ENV support",1; + ok "35 # skipped: no caseless %ENV support",1; } diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t index f1b1888..1c6f3c5 100755 --- a/contrib/perl5/t/op/method.t +++ b/contrib/perl5/t/op/method.t @@ -4,7 +4,7 @@ # test method calls and autoloading. # -print "1..26\n"; +print "1..49\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -19,6 +19,35 @@ sub test { print "ok ", ++$cnt, "\n" } +# First, some basic checks of method-calling syntax: +$obj = bless [], "Pack"; +sub Pack::method { shift; join(",", "method", @_) } +$mname = "method"; + +test(Pack->method("a","b","c"), "method,a,b,c"); +test(Pack->$mname("a","b","c"), "method,a,b,c"); +test(method Pack ("a","b","c"), "method,a,b,c"); +test((method Pack "a","b","c"), "method,a,b,c"); + +test(Pack->method(), "method"); +test(Pack->$mname(), "method"); +test(method Pack (), "method"); +test(Pack->method, "method"); +test(Pack->$mname, "method"); +test(method Pack, "method"); + +test($obj->method("a","b","c"), "method,a,b,c"); +test($obj->$mname("a","b","c"), "method,a,b,c"); +test((method $obj ("a","b","c")), "method,a,b,c"); +test((method $obj "a","b","c"), "method,a,b,c"); + +test($obj->method(), "method"); +test($obj->$mname(), "method"); +test((method $obj ()), "method"); +test($obj->method, "method"); +test($obj->$mname, "method"); +test(method $obj, "method"); + test( A->d, "C::d"); # Update hash table; *B::d = \&D::d; # Import now. @@ -126,3 +155,15 @@ test(A->eee(), "new B: In A::eee, 4"); # Which sticks # this test added due to bug discovery test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); + +# test that failed subroutine calls don't affect method calls +{ + package A1; + sub foo { "foo" } + package A2; + @ISA = 'A1'; + package main; + test(A2->foo(), "foo"); + test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); + test(A2->foo(), "foo"); +} diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index c9050ef..ac1a44f 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -4,7 +4,7 @@ # separate executable and can't simply use eval. chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -25,22 +25,25 @@ for (@prgs){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + if ($^O eq 'MSWin32') { - open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1"; + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; } else { - open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + $results = `./perl $switch $tmpfile 2>&1`; } - print TEST $prog, "\n"; - close TEST; $status = $?; - $results = `$CAT $tmpfile`; $results =~ s/\n+$//; + $results =~ s/at\s+misctmp\d+\s+line/at - line/g; + $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; - if ( $results ne $expected){ + if ( $results ne $expected ) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; @@ -56,11 +59,12 @@ $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## +use integer; $cusp = ~0 ^ (~0 >> 1); $, = " "; print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; EXPECT -7 0 0 1 ! +-1 0 0 1 ! ######## $foo=undef; $foo->go; EXPECT @@ -77,7 +81,7 @@ $x=0x0eabcd; print $x->ref; EXPECT Can't call method "ref" without a package or object reference at - line 1. ######## -chop ($str .= <STDIN>); +chop ($str .= <DATA>); ######## close ($banana); ######## @@ -89,7 +93,7 @@ eval {sub bar {print "In bar";}} ######## system './perl -ne "print if eof" /dev/null' ######## -chop($file = <>); +chop($file = <DATA>); ######## package N; sub new {my ($obj,$n)=@_; bless \$n} @@ -101,7 +105,7 @@ EXPECT ######## %@x=0; EXPECT -Can't modify hash deref in repeat at - line 1, near "0;" +Can't modify hash dereference in repeat (x) at - line 1, near "0;" Execution of - aborted due to compilation errors. ######## $_="foo"; @@ -346,20 +350,22 @@ Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern ######## /(?{"{"}})/ # Check it outside of eval too EXPECT -Unmatched right bracket at (re_eval 1) line 1, at end of line +Unmatched right curly bracket at (re_eval 1) line 1, at end of line syntax error at (re_eval 1) line 1, near ""{"}" Compilation failed in regexp at - line 1. ######## -BEGIN { @ARGV = qw(a b c) } +BEGIN { @ARGV = qw(a b c d e) } BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } END { print "end <",shift,">\nargv <@ARGV>\n" } INIT { print "init <",shift,">\n" } +CHECK { print "check <",shift,">\n" } EXPECT -argv <a b c> +argv <a b c d e> begin <a> -init <b> -end <c> -argv <> +check <b> +init <c> +end <d> +argv <e> ######## -l # fdopen from a system descriptor to a system descriptor used to close @@ -433,6 +439,54 @@ foo bar BEGIN failed--compilation aborted at - line 8. ######## +package X; +@ISA='Y'; +sub new { + my $class = shift; + my $self = { }; + bless $self, $class; + my $init = shift; + $self->foo($init); + print "new", $init; + return $self; +} +sub DESTROY { + my $self = shift; + print "DESTROY", $self->foo; +} +package Y; +sub attribute { + my $self = shift; + my $var = shift; + if (@_ == 0) { + return $self->{$var}; + } elsif (@_ == 1) { + $self->{$var} = shift; + } +} +sub AUTOLOAD { + $AUTOLOAD =~ /::([^:]+)$/; + my $method = $1; + splice @_, 1, 0, $method; + goto &attribute; +} +package main; +my $x = X->new(1); +for (2..3) { + my $y = X->new($_); + print $y->foo; +} +print $x->foo; +EXPECT +new1new22DESTROY2new33DESTROY31DESTROY1 +######## +re(); +sub re { + my $re = join '', eval 'qr/(??{ $obj->method })/'; + $re; +} +EXPECT +######## use strict; my $foo = "ZZZ\n"; END { print $foo } @@ -446,3 +500,48 @@ END { print $foo } '; EXPECT ZZZ +######## +-w +if (@ARGV) { print "" } +else { + if ($x == 0) { print "" } else { print $x } +} +EXPECT +Use of uninitialized value in numeric eq (==) at - line 4. +######## +$x = sub {}; +foo(); +sub foo { eval { return }; } +print "ok\n"; +EXPECT +ok +######## +my @l = qw(hello.* world); +my $x; + +foreach $x (@l) { + print "before - $x\n"; + $x = "\Q$x\E"; + print "quotemeta - $x\n"; + $x = "\u$x"; + print "ucfirst - $x\n"; + $x = "\l$x"; + print "lcfirst - $x\n"; + $x = "\U$x\E"; + print "uc - $x\n"; + $x = "\L$x\E"; + print "lc - $x\n"; +} +EXPECT +before - hello.* +quotemeta - hello\.\* +ucfirst - Hello\.\* +lcfirst - hello\.\* +uc - HELLO\.\* +lc - hello\.\* +before - world +quotemeta - world +ucfirst - World +lcfirst - world +uc - WORLD +lc - world diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index acf16c1..cf8e55d 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -1,18 +1,25 @@ #!./perl -# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $ +print "1..9\n"; -print "1..7\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`; +use File::Path; +rmtree('blurfl'); # tests 3 and 7 rather naughtily expect English error messages $ENV{'LC_ALL'} = 'C'; +$ENV{LANGUAGE} = 'C'; # GNU locale extension print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); +print ($! =~ /cannot move|exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n"); +print ($! =~ /cannot find|such|exist|not found/i ? "ok 7\n" : "# $!\nnot ok 7\n"); +print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n"); +print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n"); diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t new file mode 100755 index 0000000..fd36e2e --- /dev/null +++ b/contrib/perl5/t/op/nothr5005.t @@ -0,0 +1,35 @@ +#!./perl + +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + +BEGIN + { + chdir 't' if -d 't'; + unshift @INC, "../lib"; + require Config; + import Config; + if ($Config{'use5005threads'}) + { + print "1..0 # Skip: this perl is threaded\n"; + exit 0; + } + } + + +$|=1; + +print "1..9\n"; +$t = 1; +sub foo { local(@_) = ('p', 'q', 'r'); } +sub bar { unshift @_, 'D'; @_ } +sub baz { push @_, 'E'; return @_ } +for (1..3) + { + print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr'; + print "ok ",$t++,"\n"; + print "not" unless join('',bar('d')) eq 'Dd'; + print "ok ",$t++,"\n"; + print "not" unless join('',baz('e')) eq 'eE'; + print "ok ",$t++,"\n"; + } diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t new file mode 100755 index 0000000..8eb9b6e --- /dev/null +++ b/contrib/perl5/t/op/numconvert.t @@ -0,0 +1,186 @@ +#!./perl + +# +# test the conversion operators +# +# Notations: +# +# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N +# Compare with application of op-N, then reporter-N +# Right below are descriptions of different ops and reporters. + +# We do not use these subroutines any more, sub overhead makes a "switch" +# solution better: + +# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) + +# *0 = sub {--$_[0]}; # - +# *1 = sub {++$_[0]}; # + + +# # Converters +# *2 = sub { $_[0] = $max_uv & $_[0]}; # U +# *3 = sub { use integer; $_[0] += $zero}; # I +# *4 = sub { $_[0] += $zero}; # N +# *5 = sub { $_[0] = "$_[0]" }; # P + +# # Side effects +# *6 = sub { $max_uv & $_[0]}; # u +# *7 = sub { use integer; $_[0] + $zero}; # i +# *8 = sub { $_[0] + $zero}; # n +# *9 = sub { $_[0] . "" }; # p + +# # Reporters +# sub a2 { sprintf "%u", $_[0] } # U +# sub a3 { sprintf "%d", $_[0] } # I +# sub a4 { sprintf "%g", $_[0] } # N +# sub a5 { "$_[0]" } # P + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict 'vars'; + +my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; + +# Bulk out if unsigned type is hopelessly wrong: +my $max_uv1 = ~0; +my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here +my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here + +print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; +if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { + print "1..0\n# Unsigned arithmetic is not sane\n"; + exit 0; +} + +my $st_t = 4*4; # We try 4 initializers and 4 reporters + +my $num = 0; +$num += 10**$_ - 4**$_ for 1.. $max_chain; +$num *= $st_t; +print "1..$num\n"; # In fact 15 times more subsubtests... + +my $max_uv = ~0; +my $max_iv = int($max_uv/2); +my $zero = 0; + +my $l_uv = length $max_uv; +my $l_iv = length $max_iv; + +# Hope: the first digits are good +my $larger_than_uv = substr 97 x 100, 0, $l_uv; +my $smaller_than_iv = substr 12 x 100, 0, $l_iv; +my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); + +my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, + $max_uv, $max_uv + 1); +unshift @list, (reverse map -$_, @list), 0; # 15 elts +@list = map "$_", @list; # Normalize + +# print "@list\n"; + + +my @opnames = split //, "-+UINPuinp"; + +# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input + +#print "@list\n"; +#print "'@ops'\n"; + +my $test = 1; +my $nok; +for my $num_chain (1..$max_chain) { + my @ops = map [split //], grep /[4-9]/, + map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; + + #@ops = ([]) unless $num_chain; + #@ops = ([6, 4]); + + # print "'@ops'\n"; + for my $op (@ops) { + for my $first (2..5) { + for my $last (2..5) { + $nok = 0; + my @otherops = grep $_ <= 3, @$op; + my @curops = ($op,\@otherops); + + for my $num (@list) { + my $inpt; + my @ans; + + for my $short (0, 1) { + # undef $inpt; # Forget all we had - some bugs were masked + + $inpt = $num; # Try to not contaminate $num... + $inpt = "$inpt"; + if ($first == 2) { + $inpt = $max_uv & $inpt; # U 2 + } elsif ($first == 3) { + use integer; $inpt += $zero; # I 3 + } elsif ($first == 4) { + $inpt += $zero; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + + # Saves 20% of time - not with this logic: + #my $tmp = $inpt; + #my $tmp1 = $num; + #next if $num_chain > 1 + # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... + + for my $curop (@{$curops[$short]}) { + if ($curop < 5) { + if ($curop < 3) { + if ($curop == 0) { + --$inpt; # - 0 + } elsif ($curop == 1) { + ++$inpt; # + 1 + } else { + $inpt = $max_uv & $inpt; # U 2 + } + } elsif ($curop == 3) { + use integer; $inpt += $zero; + } else { + $inpt += $zero; # N 4 + } + } elsif ($curop < 8) { + if ($curop == 5) { + $inpt = "$inpt"; # P 5 + } elsif ($curop == 6) { + $max_uv & $inpt; # u 6 + } else { + use integer; $inpt + $zero; + } + } elsif ($curop == 8) { + $inpt + $zero; # n 8 + } else { + $inpt . ""; # p 9 + } + } + + if ($last == 2) { + $inpt = sprintf "%u", $inpt; # U 2 + } elsif ($last == 3) { + $inpt = sprintf "%d", $inpt; # I 3 + } elsif ($last == 4) { + $inpt = sprintf "%g", $inpt; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + 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]; + } + print "not " if $nok; + print "ok $test\n"; + #print $txt if $nok; + $test++; + } + } + } +} diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 6623089..27ac5aa 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,13 +1,53 @@ #!./perl -print "1..9\n"; - -print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; -print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; -print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; -print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; -print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; -print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; -print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; -print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; -print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n"; +print "1..36\n"; + +print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n"; +print +(oct('0b10101') == 21) ? "ok" : "not ok", " 3\n"; +print +(oct('0b10101') == 0x15) ? "ok" : "not ok", " 4\n"; + +print +(oct('b10101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b10101') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b10101') == 0x15) ? "ok" : "not ok", " 8\n"; + +print +(oct('01234') == 0b1010011100) ? "ok" : "not ok", " 9\n"; +print +(oct('01234') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('01234') == 668) ? "ok" : "not ok", " 11\n"; +print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; + +print +(oct('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n"; + +print +(oct('x1234') == 0b1001000110100) ? "ok" : "not ok", " 17\n"; +print +(oct('x1234') == 011064) ? "ok" : "not ok", " 18\n"; +print +(oct('x1234') == 4660) ? "ok" : "not ok", " 19\n"; +print +(oct('x1234') == 0x1234) ? "ok" : "not ok", " 20\n"; + +print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('01234') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('01234') == 4660) ? "ok" : "not ok", " 23\n"; +print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 24\n"; + +print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; +print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 26\n"; +print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 27\n"; +print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 28\n"; + +print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; +print +(hex('x1234') == 011064) ? "ok" : "not ok", " 30\n"; +print +(hex('x1234') == 4660) ? "ok" : "not ok", " 31\n"; +print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 32\n"; + +print +(oct('0b11111111111111111111111111111111') == 4294967295) ? + "ok" : "not ok", " 33\n"; +print +(oct('037777777777') == 4294967295) ? + "ok" : "not ok", " 34\n"; +print +(oct('0xffffffff') == 4294967295) ? + "ok" : "not ok", " 35\n"; + +print +(hex('0xffffffff') == 4294967295) ? + "ok" : "not ok", " 36\n"; diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t index ba943f4..22ff3af 100755 --- a/contrib/perl5/t/op/ord.t +++ b/contrib/perl5/t/op/ord.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $ - -print "1..3\n"; +print "1..5\n"; # compile time evaluation @@ -10,9 +8,16 @@ print "1..3\n"; # 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; +print "ok 2\n"; + # run time evaluation $x = 'ABC'; -if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} +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";} -if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} +$x = 500; +print "not " unless ord(chr($x)) == $x; +print "ok 5\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index 902fc28..b336cb5 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..142\n"; +print "1..156\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -19,7 +19,10 @@ print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); $out1=join(':',@ary); $out2=join(':',@ary2); -print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n"); +# Using long double NVs may introduce greater accuracy than wanted. +$out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; +$out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; +print ($out1 eq $out2? "ok 2\n" : "not ok 2\n"); print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); @@ -95,7 +98,7 @@ print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); # temps sub foo { my $a = "a"; return $a . $a++ . $a++ } { - local $^W = 1; + use warnings; my $last = $test; local $SIG{__WARN__} = sub { print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ @@ -208,7 +211,7 @@ EOUU print "not " unless unpack('u', $uu) eq $in; print "ok ", $test++, "\n"; -# 61..72: test the ascii template types (A, a, Z) +# 61..73: test the ascii template types (A, a, Z) print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; print "ok ", $test++, "\n"; @@ -234,115 +237,116 @@ print "ok ", $test++, "\n"; print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; print "ok ", $test++, "\n"; -print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 \0"; print "ok ", $test++, "\n"; print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; print "ok ", $test++, "\n"; +print "not " unless pack('Z3', "foo") eq "fo\0"; +print "ok ", $test++, "\n"; + print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; print "ok ", $test++, "\n"; print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; print "ok ", $test++, "\n"; -# 73..78: packing native shorts/ints/longs +# 74..79: packing native shorts/ints/longs -# integrated from mainline and don't want to change numbers all the way -# down. native ints are not supported in _0x so comment out checks -#print "not " unless length(pack("s!", 0)) == $Config{shortsize}; +print "not " unless length(pack("s!", 0)) == $Config{shortsize}; print "ok ", $test++, "\n"; -#print "not " unless length(pack("i!", 0)) == $Config{intsize}; +print "not " unless length(pack("i!", 0)) == $Config{intsize}; print "ok ", $test++, "\n"; -#print "not " unless length(pack("l!", 0)) == $Config{longsize}; +print "not " unless length(pack("l!", 0)) == $Config{longsize}; print "ok ", $test++, "\n"; -#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); +print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); print "ok ", $test++, "\n"; -#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); +print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); print "ok ", $test++, "\n"; -#print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); +print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); print "ok ", $test++, "\n"; -# 79..138: pack <-> unpack bijectionism +# 80..139: pack <-> unpack bijectionism -# 79.. 83 c +# 80.. 84 c foreach my $c (-128, -1, 0, 1, 127) { print "not " unless unpack("c", pack("c", $c)) == $c; print "ok ", $test++, "\n"; } -# 84.. 88: C +# 85.. 89: C foreach my $C (0, 1, 127, 128, 255) { print "not " unless unpack("C", pack("C", $C)) == $C; print "ok ", $test++, "\n"; } -# 89.. 93: s +# 90.. 94: s foreach my $s (-32768, -1, 0, 1, 32767) { print "not " unless unpack("s", pack("s", $s)) == $s; print "ok ", $test++, "\n"; } -# 94.. 98: S +# 95.. 99: S foreach my $S (0, 1, 32767, 32768, 65535) { print "not " unless unpack("S", pack("S", $S)) == $S; print "ok ", $test++, "\n"; } -# 99..103: i +# 100..104: i foreach my $i (-2147483648, -1, 0, 1, 2147483647) { print "not " unless unpack("i", pack("i", $i)) == $i; print "ok ", $test++, "\n"; } -# 104..108: I +# 105..109: I foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { print "not " unless unpack("I", pack("I", $I)) == $I; print "ok ", $test++, "\n"; } -# 109..113: l +# 110..114: l foreach my $l (-2147483648, -1, 0, 1, 2147483647) { print "not " unless unpack("l", pack("l", $l)) == $l; print "ok ", $test++, "\n"; } -# 114..118: L +# 115..119: L foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { print "not " unless unpack("L", pack("L", $L)) == $L; print "ok ", $test++, "\n"; } -# 119..123: n +# 120..124: n foreach my $n (0, 1, 32767, 32768, 65535) { print "not " unless unpack("n", pack("n", $n)) == $n; print "ok ", $test++, "\n"; } -# 124..128: v +# 125..129: v foreach my $v (0, 1, 32767, 32768, 65535) { print "not " unless unpack("v", pack("v", $v)) == $v; print "ok ", $test++, "\n"; } -# 129..133: N +# 130..134: N foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { print "not " unless unpack("N", pack("N", $N)) == $N; print "ok ", $test++, "\n"; } -# 134..138: V +# 135..139: V foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { print "not " unless unpack("V", pack("V", $V)) == $V; print "ok ", $test++, "\n"; } -# 139..142: pack nvNV byteorders +# 140..143: pack nvNV byteorders print "not " unless pack("n", 0xdead) eq "\xde\xad"; print "ok ", $test++, "\n"; @@ -355,3 +359,49 @@ print "ok ", $test++, "\n"; print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; print "ok ", $test++, "\n"; + +# 144..152: / + +my $z; +eval { ($x) = unpack '/a*','hello' }; +print 'not ' unless $@; print "ok $test\n"; $test++; +eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; +print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; + +eval { ($x) = pack '/a*','hello' }; +print 'not ' unless $@; print "ok $test\n"; $test++; +$z = pack 'n/a* w/A*','string','etc'; +print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; +print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; +$test++; + +eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' }; +print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; +$test++; + +eval { ($x) = unpack 'a/a*/b*', '212ab' }; +my $expected_x = '100001100100'; +if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; } +print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; +$test++; + +# 153..156: / with # + +eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; + a3/A # Count in ASCII + C/a* # Count in a C char + C/Z # Count in a C char but skip after \0 +EOU +print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; + +$z = pack <<EOP,'string','etc'; + n/a* # Count as network short + w/A* # Count a BER integer +EOP +print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index ed8c778..188a3a3 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,11 +4,11 @@ # 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..142\n"; +print "1..211\n"; BEGIN { chdir 't' if -d 't'; - @INC = "../lib" if -d "../lib"; + unshift @INC, "../lib" if -d "../lib"; } eval 'use Config'; # Defaults assumed if this fails @@ -282,14 +282,7 @@ eval qq("${context}y" =~ /(?<=$context)y/); print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; print "ok 71\n"; -# This one will fail when POSIX character classes do get implemented -{ - my $w; - local $^W = 1; - local $SIG{__WARN__} = sub{$w = shift}; - eval q('a' =~ /[[:alpha:]]/); - print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/; -} +# removed test print "ok 72\n"; # Long Monsters @@ -363,6 +356,7 @@ sub matchit { /xg; } +@ans = (); push @ans, $res while $res = matchit; print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; @@ -375,6 +369,30 @@ print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; print "ok $test\n"; $test++; +print "not " unless "abc" =~ /^(??{"a"})b/; +print "ok $test\n"; +$test++; + +my $matched; +$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; + +@ans = @ans1 = (); +push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; +print "ok $test\n"; +$test++; + +print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; +print "ok $test\n"; +$test++; + +@ans = m/$matched/g; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; +print "ok $test\n"; +$test++; + @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad print "not " if "@ans" ne 'a/ b'; print "ok $test\n"; @@ -555,8 +573,8 @@ sub must_warn_pat { sub must_warn { my ($warn_pat, $code) = @_; - local $^W; local %SIG; - eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code; + local %SIG; + eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; print "ok $test\n"; $test++; } @@ -595,8 +613,385 @@ print "not " if @_; print "ok $test\n"; $test++; +/a(?=.$)/; +print "not " if $#+ != 0 or $#- != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 2 or $-[0] != 1; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2]; +print "ok $test\n"; +$test++; + +/a(a)(a)/; +print "not " if $#+ != 2 or $#- != 2; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 3 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[2] != 3 or $-[2] != 2; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4]; +print "ok $test\n"; +$test++; + +/.(a)(b)?(a)/; +print "not " if $#+ != 3 or $#- != 3; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 3 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[3] != 3 or $-[3] != 2; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4]; +print "ok $test\n"; +$test++; + +/.(a)/; +print "not " if $#+ != 1 or $#- != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 2 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3]; +print "ok $test\n"; +$test++; + +/.(a)(ba*)?/; +print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; +print "ok $test\n"; +$test++; + +$_ = 'aaa'; +pos = 1; +@a = /\Ga/g; +print "not " unless "@a" eq "a a"; +print "ok $test\n"; +$test++; + +$str = 'abcde'; +pos $str = 2; + +print "not " if $str =~ /^\G/; +print "ok $test\n"; +$test++; + +print "not " if $str =~ /^.\G/; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /^..\G/; +print "ok $test\n"; +$test++; + +print "not " if $str =~ /^...\G/; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /.\G./ and $& eq 'bc'; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /\G../ and $& eq 'cd'; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless $str =~ /b(?{$foo = $_; $bar = pos})c/ + and $foo eq 'abcde' and $bar eq 2; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +pos $str = undef; +print "#'$str','$foo','$bar'\nnot " + unless $str =~ /b(?{$foo = $_; $bar = pos})c/g + and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; +print "ok $test\n"; +$test++; + +$_ = $str; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless /b(?{$foo = $_; $bar = pos})c/ + and $foo eq 'abcde' and $bar eq 2; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless /b(?{$foo = $_; $bar = pos})c/g + and $foo eq 'abcde' and $bar eq 2 and pos eq 3; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +pos = undef; +1 while /b(?{$foo = $_; $bar = pos})c/g; +print "#'$str','$foo','$bar'\nnot " + unless $foo eq 'abcde' and $bar eq 2 and not defined pos; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +$_ = 'abcde|abcde'; +print "#'$str','$foo','$bar','$_'\nnot " + unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' + and $bar eq 8 and $_ eq 'axde|axde'; +print "ok $test\n"; +$test++; + +@res = (); +# List context: +$_ = 'abcde|abcde'; +@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; +@res = map {defined $_ ? "'$_'" : 'undef'} @res; +$res = "@res"; +print "#'@res' '$_'\nnot " + unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; +print "ok $test\n"; +$test++; + +@res = (); +@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; +@res = map {defined $_ ? "'$_'" : 'undef'} @res; +$res = "@res"; +print "#'@res' '$_'\nnot " + unless "@res" eq + "'' 'ab' 'cde|abcde' " . + "'' 'abc' 'de|abcde' " . + "'abcd' 'e|' 'abcde' " . + "'abcde|' 'ab' 'cde' " . + "'abcde|' 'abc' 'de'" ; +print "ok $test\n"; +$test++; + +#Some more \G anchor checks +$foo='aabbccddeeffgg'; + +pos($foo)=1; + +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'ab'); +print "ok $test\n"; +$test++; + +pos($foo) += 1; +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'cc'); +print "ok $test\n"; +$test++; + +pos($foo) += 1; +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'de'); +print "ok $test\n"; +$test++; + +print "not " unless $foo =~ /\Gef/g; +print "ok $test\n"; +$test++; + +undef pos $foo; + +$foo=~/\G(..)/g; +print "not " unless($1 eq 'aa'); +print "ok $test\n"; +$test++; + +$foo=~/\G(..)/g; +print "not " unless($1 eq 'bb'); +print "ok $test\n"; +$test++; + +pos($foo)=5; +$foo=~/\G(..)/g; +print "not " unless($1 eq 'cd'); +print "ok $test\n"; +$test++; + +$_='123x123'; +@res = /(\d*|x)/g; +print "not " unless('123||x|123|' eq join '|', @res); +print "ok $test\n"; +$test++; + # see if matching against temporaries (created via pp_helem()) is safe { foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; print "$1\n"; $test++; +# See if $i work inside (?{}) in the presense of saved substrings and +# changing $_ +@a = qw(foo bar); +@b = (); +s/(\w)(?{push @b, $1})/,$1,/g for @a; + +print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); +print "ok $test\n"; +$test++; + +print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); +print "ok $test\n"; +$test++; + +$brackets = qr{ + { (?> [^{}]+ | (??{ $brackets }) )* } + }x; + +"{{}" =~ $brackets; +print "ok $test\n"; # Did we survive? +$test++; + +"something { long { and } hairy" =~ $brackets; +print "ok $test\n"; # Did we survive? +$test++; + +"something { long { and } hairy" =~ m/((??{ $brackets }))/; +print "not " unless $1 eq "{ and }"; +print "ok $test\n"; +$test++; + +$_ = "a-a\nxbb"; +pos=1; +m/^-.*bb/mg and print "not "; +print "ok $test\n"; +$test++; + +$text = "aaXbXcc"; +pos($text)=0; +$text =~ /\GXb*X/g and print 'not '; +print "ok $test\n"; +$test++; + +$text = "xA\n" x 500; +$text =~ /^\s*A/m and print 'not '; +print "ok $test\n"; +$test++; + +$text = "abc dbf"; +@res = ($text =~ /.*?(b).*?\b/g); +"@res" eq 'b b' or print 'not '; +print "ok $test\n"; +$test++; + +@a = map chr,0..255; + +@b = grep(/\S/,@a); +@c = grep(/[^\s]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\S/,@a); +@c = grep(/[\S]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\s/,@a); +@c = grep(/[^\S]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\s/,@a); +@c = grep(/[\s]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\D/,@a); +@c = grep(/[^\d]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\D/,@a); +@c = grep(/[\D]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\d/,@a); +@c = grep(/[^\D]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\d/,@a); +@c = grep(/[\d]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\W/,@a); +@c = grep(/[^\w]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\W/,@a); +@c = grep(/[\W]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\w/,@a); +@c = grep(/[^\W]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\w/,@a); +@c = grep(/[\w]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +# see if backtracking optimization works correctly +"\n\n" =~ /\n $ \n/x or print "not "; +print "ok $test\n"; +$test++; + +"\n\n" =~ /\n* $ \n/x or print "not "; +print "ok $test\n"; +$test++; + +"\n\n" =~ /\n+ $ \n/x or print "not "; +print "ok $test\n"; +$test++; diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t new file mode 100755 index 0000000..ca14a99 --- /dev/null +++ b/contrib/perl5/t/op/pwent.t @@ -0,0 +1,137 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib" if -d "../lib"; + eval {my @n = getpwuid 0}; + if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { + print "1..0 # Skip: $1\n"; + exit 0; + } + eval { require Config; import Config; }; + my $reason; + if ($Config{'i_pwd'} ne 'define') { + $reason = '$Config{i_pwd} undefined'; + } + elsif (not -f "/etc/passwd" ) { # Play safe. + $reason = 'no /etc/passwd file'; + } + + if (not defined $where) { # Try NIS. + foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { + if (-x $ypcat && + open(PW, "$ypcat passwd 2>/dev/null |") && + defined(<PW>)) { + $where = "NIS passwd"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try NetInfo. + foreach my $nidump (qw(/usr/bin/nidump)) { + if (-x $nidump && + open(PW, "$nidump passwd . 2>/dev/null |") && + defined(<PW>)) { + $where = "NetInfo passwd"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try local. + my $PW = "/etc/passwd"; + if (-f $PW && open(PW, $PW) && defined(<PW>)) { + $where = $PW; + undef $reason; + } + } + + if ($reason) { # Give up. + print "1..0 # Skip: $reason\n"; + exit 0; + } +} + +# By now PW filehandle should be open and full of juicy password entries. + +print "1..1\n"; + +# Go through at most this many users. +# (note that the first entry has been read away by now) +my $max = 25; + +my $n = 0; +my $tst = 1; +my %perfect; +my %seen; + +while (<PW>) { + chomp; + my @s = split /:/; + my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + next if /^\+/; # ignore NIS includes + if (@s) { + push @{ $seen{$name_s} }, $.; + } else { + warn "# Your $where line $. is empty.\n"; + next; + } + if ($n == $max) { + local $/; + my $junk = <PW>; + last; + } + # In principle we could whine if @s != 7 but do we know enough + # of passwd file formats everywhere? + if (@s == 7) { + @n = getpwuid($uid_s); + # 'nobody' et al. + next unless @n; + my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; + # Protect against one-to-many and many-to-one mappings. + if ($name_s ne $name) { + @n = getpwnam($name_s); + ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; + next if $name_s ne $name; + } + $perfect{$name_s}++ + if $name eq $name_s and + $uid eq $uid_s and +# Do not compare passwords: think shadow passwords. + $gid eq $gid_s and + $gcos eq $gcos_s and + $home eq $home_s and + $shell eq $shell_s; + } + $n++; +} + +if (keys %perfect == 0) { + $max++; + print <<EOEX; +# +# The failure of op/pwent test is not necessarily serious. +# It may fail due to local password administration conventions. +# If you are for example using both NIS and local passwords, +# test failure is possible. Any distributed password scheme +# can cause such failures. +# +# What the pwent test is doing is that it compares the $max first +# entries of $where +# with the results of getpwuid() and getpwnam() call. If it finds no +# matches at all, it suspects something is wrong. +# +EOEX + print "not "; + $not = 1; +} else { + $not = 0; +} +print "ok ", $tst++; +print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not; +print "\n"; + +close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t index 913e07c..60e5b7b 100755 --- a/contrib/perl5/t/op/quotemeta.t +++ b/contrib/perl5/t/op/quotemeta.t @@ -1,8 +1,14 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + print "1..15\n"; -if ($^O eq 'os390') { # An EBCDIC variant. +if ($Config{ebcdic} eq 'define') { $_=join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t index c779f9d..97019bb 100755 --- a/contrib/perl5/t/op/rand.t +++ b/contrib/perl5/t/op/rand.t @@ -17,7 +17,7 @@ BEGIN { chdir "t" if -d "t"; - @INC = "../lib" if -d "../lib"; + unshift @INC, "../lib" if -d "../lib"; } use strict; @@ -52,6 +52,17 @@ sub bits ($) { $max = $min = rand(1); for (1..$reps) { my $n = rand(1); + if ($n < 0.0 or $n >= 1.0) { + print <<EOM; +# WHOA THERE! \$Config{drand01} is set to '$Config{drand01}', +# but that apparently produces values < 0.0 or >= 1.0. +# Make sure \$Config{drand01} is a valid expression in the +# C-language, and produces values in the range [0.0,1.0). +# +# I give up. +EOM + exit; + } $sum += $n; $bits += bits($n * 256); # Don't be greedy; 8 is enough # It's too many if randbits is less than 8! @@ -74,8 +85,8 @@ sub bits ($) { # reason that the diagnostic message might get the # wrong value is that Config.pm is incorrect.) # - if ($max <= 0 or $max >= (1 << $randbits)) { # Just in case... - print "not ok 1\n"; + if ($max <= 0 or $max >= (2 ** $randbits)) {# Just in case... + print "# max=[$max] min=[$min]\nnot ok 1\n"; print "# This perl was compiled with randbits=$randbits\n"; print "# which is _way_ off. Or maybe your system rand is broken,\n"; print "# or your C compiler can't multiply, or maybe Martians\n"; @@ -91,7 +102,7 @@ sub bits ($) { $off = int($off) + ($off > 0); # Next more positive int if ($off) { $shouldbe = $Config{randbits} + $off; - print "not ok 1\n"; + print "# max=[$max] min=[$min]\nnot ok 1\n"; print "# This perl was compiled with randbits=$randbits on $^O.\n"; print "# Consider using randbits=$shouldbe instead.\n"; # And skip the remaining tests; they would be pointless now. diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t index 01f5f70..e8aecf5 100755 --- a/contrib/perl5/t/op/range.t +++ b/contrib/perl5/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..12\n"; +print "1..15\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -55,3 +55,21 @@ print "ok 11\n"; print "not " unless "@a" eq "-2147483647 -2147483646"; print "ok 12\n"; +# check magic +{ + my $bad = 0; + local $SIG{'__WARN__'} = sub { $bad = 1 }; + my $x = 'a-e'; + $x =~ s/(\w)-(\w)/join ':', $1 .. $2/e; + $bad = 1 unless $x eq 'a:b:c:d:e'; + print $bad ? "not ok 13\n" : "ok 13\n"; +} + +# Should use magical autoinc only when both are strings +print "not " unless 0 == (() = "0"..-1); +print "ok 14\n"; + +for my $x ("0"..-1) { + print "not "; +} +print "ok 15\n"; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index 3471cc3..d506e6e 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -45,7 +45,7 @@ a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- -a[b-a] - c - /a[b-a]/: invalid [] range in regexp +a[b-a] - c - /a[b-a]/: invalid [] range "b-a" in regexp a[]b - c - /a[]b/: unmatched [] in regexp a[ - c - /a[/: unmatched [] in regexp a] a] y $& a] @@ -218,7 +218,7 @@ a[-]?c ac y $& ac 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- -'a[b-a]'i - c - /a[b-a]/: invalid [] range in regexp +'a[b-a]'i - c - /a[b-a]/: invalid [] range "b-a" in regexp 'a[]b'i - c - /a[]b/: unmatched [] in regexp 'a['i - c - /a[/: unmatched [] in regexp 'a]'i A] y $& A] @@ -402,7 +402,7 @@ a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{"\{"})b cabd y $& ab -a(?{"{"}})b - c - Unmatched right bracket +a(?{"{"}})b - c - Unmatched right curly bracket a(?{$bl="\{"}).b caxbd y $bl { x(~~)*(?:(?:F)?)? x~~ y - - ^a(?#xxx){3}c aaac y $& aaac @@ -474,18 +474,279 @@ $(?<=^(a)) a y $1 a ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ [a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp -[a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp -([a[:xyz:]b]+) pbaq y $1 ba +[a[:xyz:] - c - Character class [:xyz:] unknown +[a[:]b[:c] abc y $& abc +([a[:xyz:]b]+) pbaq c - Character class [:xyz:] unknown +[a[:]b[:c] abc y $& abc +([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd +([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy +([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul} +([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul} +([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 +([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd +([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- +([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 +([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__ +([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB +([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01 +([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 +([[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff} +([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff} +([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd +([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB +([[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff} +([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy +([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} +([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 +([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} +[[:foo:]] - c - Character class [:foo:] unknown +[[:^foo:]] - c - Character class [:^foo:] unknown ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x (?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +\Z a\nb\n y $-[0] 3 +\z a\nb\n y $-[0] 4 +$ a\nb\n y $-[0] 3 +\Z b\na\n y $-[0] 3 +\z b\na\n y $-[0] 4 +$ b\na\n y $-[0] 3 +\Z b\na y $-[0] 3 +\z b\na y $-[0] 3 +$ b\na y $-[0] 3 +'\Z'm a\nb\n y $-[0] 3 +'\z'm a\nb\n y $-[0] 4 +'$'m a\nb\n y $-[0] 1 +'\Z'm b\na\n y $-[0] 3 +'\z'm b\na\n y $-[0] 4 +'$'m b\na\n y $-[0] 1 +'\Z'm b\na y $-[0] 3 +'\z'm b\na y $-[0] 3 +'$'m b\na y $-[0] 1 a\Z a\nb\n n - - -b\Z a\nb\n y - - -b\z a\nb\n n - - -b\Z a\nb y - - -b\z a\nb y - - +a\z a\nb\n n - - +a$ a\nb\n n - - +a\Z b\na\n y $-[0] 2 +a\z b\na\n n - - +a$ b\na\n y $-[0] 2 +a\Z b\na y $-[0] 2 +a\z b\na y $-[0] 2 +a$ b\na y $-[0] 2 +'a\Z'm a\nb\n bn - - +'a\z'm a\nb\n n - - +'a$'m a\nb\n y $-[0] 0 +'a\Z'm b\na\n y $-[0] 2 +'a\z'm b\na\n n - - +'a$'m b\na\n y $-[0] 2 +'a\Z'm b\na y $-[0] 2 +'a\z'm b\na y $-[0] 2 +'a$'m b\na y $-[0] 2 +aa\Z aa\nb\n n - - +aa\z aa\nb\n n - - +aa$ aa\nb\n n - - +aa\Z b\naa\n y $-[0] 2 +aa\z b\naa\n n - - +aa$ b\naa\n y $-[0] 2 +aa\Z b\naa y $-[0] 2 +aa\z b\naa y $-[0] 2 +aa$ b\naa y $-[0] 2 +'aa\Z'm aa\nb\n bn - - +'aa\z'm aa\nb\n n - - +'aa$'m aa\nb\n y $-[0] 0 +'aa\Z'm b\naa\n y $-[0] 2 +'aa\z'm b\naa\n n - - +'aa$'m b\naa\n y $-[0] 2 +'aa\Z'm b\naa y $-[0] 2 +'aa\z'm b\naa y $-[0] 2 +'aa$'m b\naa y $-[0] 2 +aa\Z ac\nb\n n - - +aa\z ac\nb\n n - - +aa$ ac\nb\n n - - +aa\Z b\nac\n n - - +aa\z b\nac\n n - - +aa$ b\nac\n n - - +aa\Z b\nac n - - +aa\z b\nac n - - +aa$ b\nac n - - +'aa\Z'm ac\nb\n n - - +'aa\z'm ac\nb\n n - - +'aa$'m ac\nb\n n - - +'aa\Z'm b\nac\n n - - +'aa\z'm b\nac\n n - - +'aa$'m b\nac\n n - - +'aa\Z'm b\nac n - - +'aa\z'm b\nac n - - +'aa$'m b\nac n - - +aa\Z ca\nb\n n - - +aa\z ca\nb\n n - - +aa$ ca\nb\n n - - +aa\Z b\nca\n n - - +aa\z b\nca\n n - - +aa$ b\nca\n n - - +aa\Z b\nca n - - +aa\z b\nca n - - +aa$ b\nca n - - +'aa\Z'm ca\nb\n n - - +'aa\z'm ca\nb\n n - - +'aa$'m ca\nb\n n - - +'aa\Z'm b\nca\n n - - +'aa\z'm b\nca\n n - - +'aa$'m b\nca\n n - - +'aa\Z'm b\nca n - - +'aa\z'm b\nca n - - +'aa$'m b\nca n - - +ab\Z ab\nb\n n - - +ab\z ab\nb\n n - - +ab$ ab\nb\n n - - +ab\Z b\nab\n y $-[0] 2 +ab\z b\nab\n n - - +ab$ b\nab\n y $-[0] 2 +ab\Z b\nab y $-[0] 2 +ab\z b\nab y $-[0] 2 +ab$ b\nab y $-[0] 2 +'ab\Z'm ab\nb\n bn - - +'ab\z'm ab\nb\n n - - +'ab$'m ab\nb\n y $-[0] 0 +'ab\Z'm b\nab\n y $-[0] 2 +'ab\z'm b\nab\n n - - +'ab$'m b\nab\n y $-[0] 2 +'ab\Z'm b\nab y $-[0] 2 +'ab\z'm b\nab y $-[0] 2 +'ab$'m b\nab y $-[0] 2 +ab\Z ac\nb\n n - - +ab\z ac\nb\n n - - +ab$ ac\nb\n n - - +ab\Z b\nac\n n - - +ab\z b\nac\n n - - +ab$ b\nac\n n - - +ab\Z b\nac n - - +ab\z b\nac n - - +ab$ b\nac n - - +'ab\Z'm ac\nb\n n - - +'ab\z'm ac\nb\n n - - +'ab$'m ac\nb\n n - - +'ab\Z'm b\nac\n n - - +'ab\z'm b\nac\n n - - +'ab$'m b\nac\n n - - +'ab\Z'm b\nac n - - +'ab\z'm b\nac n - - +'ab$'m b\nac n - - +ab\Z ca\nb\n n - - +ab\z ca\nb\n n - - +ab$ ca\nb\n n - - +ab\Z b\nca\n n - - +ab\z b\nca\n n - - +ab$ b\nca\n n - - +ab\Z b\nca n - - +ab\z b\nca n - - +ab$ b\nca n - - +'ab\Z'm ca\nb\n n - - +'ab\z'm ca\nb\n n - - +'ab$'m ca\nb\n n - - +'ab\Z'm b\nca\n n - - +'ab\z'm b\nca\n n - - +'ab$'m b\nca\n n - - +'ab\Z'm b\nca n - - +'ab\z'm b\nca n - - +'ab$'m b\nca n - - +abb\Z abb\nb\n n - - +abb\z abb\nb\n n - - +abb$ abb\nb\n n - - +abb\Z b\nabb\n y $-[0] 2 +abb\z b\nabb\n n - - +abb$ b\nabb\n y $-[0] 2 +abb\Z b\nabb y $-[0] 2 +abb\z b\nabb y $-[0] 2 +abb$ b\nabb y $-[0] 2 +'abb\Z'm abb\nb\n bn - - +'abb\z'm abb\nb\n n - - +'abb$'m abb\nb\n y $-[0] 0 +'abb\Z'm b\nabb\n y $-[0] 2 +'abb\z'm b\nabb\n n - - +'abb$'m b\nabb\n y $-[0] 2 +'abb\Z'm b\nabb y $-[0] 2 +'abb\z'm b\nabb y $-[0] 2 +'abb$'m b\nabb y $-[0] 2 +abb\Z ac\nb\n n - - +abb\z ac\nb\n n - - +abb$ ac\nb\n n - - +abb\Z b\nac\n n - - +abb\z b\nac\n n - - +abb$ b\nac\n n - - +abb\Z b\nac n - - +abb\z b\nac n - - +abb$ b\nac n - - +'abb\Z'm ac\nb\n n - - +'abb\z'm ac\nb\n n - - +'abb$'m ac\nb\n n - - +'abb\Z'm b\nac\n n - - +'abb\z'm b\nac\n n - - +'abb$'m b\nac\n n - - +'abb\Z'm b\nac n - - +'abb\z'm b\nac n - - +'abb$'m b\nac n - - +abb\Z ca\nb\n n - - +abb\z ca\nb\n n - - +abb$ ca\nb\n n - - +abb\Z b\nca\n n - - +abb\z b\nca\n n - - +abb$ b\nca\n n - - +abb\Z b\nca n - - +abb\z b\nca n - - +abb$ b\nca n - - +'abb\Z'm ca\nb\n n - - +'abb\z'm ca\nb\n n - - +'abb$'m ca\nb\n n - - +'abb\Z'm b\nca\n n - - +'abb\z'm b\nca\n n - - +'abb$'m b\nca\n n - - +'abb\Z'm b\nca n - - +'abb\z'm b\nca n - - +'abb$'m b\nca n - - (^|x)(c) ca y $2 c a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - +a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2 round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz +'((?x:.) )' x y $1- x - +'((?-x:.) )'x x y $1- x- +foo.bart foo.bart y - - +'^d[x][x][x]'m abcd\ndxxx y - - +.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +tt+$ xxxtt y - - +([a-\d]+) za-9z y $1 a-9 +([\d-z]+) a0-za y $1 0-z +([\d-\s]+) a0- z y $1 0- +([a-[:digit:]]+) za-9z y $1 a-9 +([[:digit:]-z]+) =0-z= y $1 0-z +([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z +\GX.*X aaaXbX n - - +(\d+\.\d+) 3.1415926 y $1 3.1415926 +(\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c +^([a-z]:) C:/ n - - +'^\S\s+aa$'m \nx aa y - - +(^|a)b ab y - - diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t index ca19ebc..d101c2f 100755 --- a/contrib/perl5/t/op/readdir.t +++ b/contrib/perl5/t/op/readdir.t @@ -1,10 +1,21 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + eval 'opendir(NOSUCH, "no/such/directory");'; if ($@) { print "1..0\n"; exit; } print "1..3\n"; +for $i (1..2000) { + local *OP; + opendir(OP, "op") or die "can't opendir: $!"; + # should auto-closedir() here +} + if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); diff --git a/contrib/perl5/t/op/recurse.t b/contrib/perl5/t/op/recurse.t index 6594940..dc823ed 100755 --- a/contrib/perl5/t/op/recurse.t +++ b/contrib/perl5/t/op/recurse.t @@ -4,7 +4,7 @@ # test recursive functions. # -print "1..23\n"; +print "1..25\n"; sub gcd ($$) { return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); @@ -84,3 +84,33 @@ for $x (0..3) { print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); print "ok ", $i++, "\n"; print "# takeuchi($x, $y, $z) = $t\n"; + +{ + sub get_first1 { + get_list1(@_)->[0]; + } + + sub get_list1 { + return [24] unless $_[0]; + my $u = get_first1(0); + [$u]; + } + my $x = get_first1(1); + print "ok $x\n"; +} + +{ + sub get_first2 { + return get_list2(@_)->[0]; + } + + sub get_list2 { + return [25] unless $_[0]; + my $u = get_first2(0); + return [$u]; + } + my $x = get_first2(1); + print "ok $x\n"; +} + +$i = 26; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t index 1d70f9f..a2baab8 100755 --- a/contrib/perl5/t/op/ref.t +++ b/contrib/perl5/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..55\n"; +print "1..56\n"; # Test glob operations. @@ -241,11 +241,11 @@ print $$_,"\n"; package A; sub new { bless {}, shift } DESTROY { print "# destroying 'A'\nok 51\n" } - package B; + package _B; sub new { bless {}, shift } - DESTROY { print "# destroying 'B'\nok 50\n"; bless shift, 'A' } + DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' } package main; - my $b = B->new; + my $b = _B->new; } # test if $_[0] is properly protected in DESTROY() @@ -271,14 +271,22 @@ print $$_,"\n"; print "# good, didn't recurse\n"; } +# test if refgen behaves with autoviv magic + +{ + my @a; + $a[1] = "ok 53\n"; + print ${\$_} for @a; +} + # test global destruction package FINALE; { - $ref3 = bless ["ok 55\n"]; # package destruction - my $ref2 = bless ["ok 54\n"]; # lexical destruction - local $ref1 = bless ["ok 53\n"]; # dynamic destruction + $ref3 = bless ["ok 56\n"]; # package destruction + my $ref2 = bless ["ok 55\n"]; # lexical destruction + local $ref1 = bless ["ok 54\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t index 11b3ee3..4ffe136 100755 --- a/contrib/perl5/t/op/regexp.t +++ b/contrib/perl5/t/op/regexp.t @@ -16,6 +16,8 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # y expect a match # n expect no match # c expect an error +# B test exposes a known bug in Perl, should be skipped +# b test exposes a known bug in Perl, should be skipped if noamp # # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. # @@ -31,7 +33,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } $iters = shift || 1; # Poor man performance suite, 10000 is OK. @@ -45,6 +47,8 @@ seek(TESTS,0,0); $. = 0; $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. +$ffff = chr(0xff) x 2; +$nulnul = "\0" x 2; $| = 1; print "1..$numtests\n# $iters iterations\n"; @@ -57,12 +61,18 @@ while (<TESTS>) { infty_subst(\$pat); infty_subst(\$expect); $pat = "'$pat'" unless $pat =~ /^[:']/; - $pat =~ s/\\n/\n/g; $pat =~ s/(\$\{\w+\})/$1/eeg; + $pat =~ s/\\n/\n/g; + $subject =~ s/(\$\{\w+\})/$1/eeg; $subject =~ s/\\n/\n/g; + $expect =~ s/(\$\{\w+\})/$1/eeg; $expect =~ s/\\n/\n/g; $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; - for $study ("", "study \$subject") { + $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):\]/; + $result =~ s/B//i unless $skip; + for $study ('', 'study \$subject') { $c = $iters; eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";"; chomp( $err = $@ ); @@ -70,6 +80,9 @@ while (<TESTS>) { if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST } last; # no need to study a syntax error } + elsif ( $skip ) { + print "ok $. # skipped\n"; next TEST; + } elsif ($@) { print "not ok $. $input => error `$err'\n"; next TEST; } diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t index f935bf1..c030ba9 100755 --- a/contrib/perl5/t/op/repeat.t +++ b/contrib/perl5/t/op/repeat.t @@ -42,10 +42,15 @@ print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n"; print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; # -# The test #20 is actually testing for Digital C compiler optimizer bug. +# The test #20 is actually testing for Digital C compiler optimizer bug, +# present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS), +# found in December 1998. The bug was reported to Digital^WCompaq as +# DECC 2745 (21-Dec-1998) +# GEM_BUGS 7619 (23-Dec-1998) +# As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned +# to be fixed also in 4.0G. # -# Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS) used -# to produce (as of December 1998) broken code for util.c:repeatcpy() +# The bug was as follows: broken code was produced for util.c:repeatcpy() # (a utility function for the 'x' operator) in the case *all* these # four conditions held: # @@ -68,9 +73,6 @@ print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; # 24 .........???????.??????? # 25 .........???????.???????. # -# The bug could be (obscurely) avoided by changing "from" to -# be an unsigned char pointer. -# # The bug was triggered in the "if (len == 1)" branch. The fix # was to introduce a new temporary variable. In diff -u format: # @@ -85,6 +87,9 @@ print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; # return; # } # +# The bug could also be (obscurely) avoided by changing "from" to +# be an unsigned char pointer. +# # This obscure bug was not found by the then test suite but instead # by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. # diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index bff3c36..e988ad9 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -3,11 +3,11 @@ ## ## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> ## chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; @@ -32,10 +32,10 @@ for (@prgs){ print TEST "$prog\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile` : + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN @@ -57,7 +57,7 @@ __END__ @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -174,7 +174,7 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. ######## sub sortfn { (split(/./, 'x'x10000))[0]; @@ -227,7 +227,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -Can't "next" outside a block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -285,7 +285,7 @@ package main; tie $bar, TEST; } EXPECT -Can't "next" outside a block at - line 4. +Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: @@ -335,3 +335,17 @@ tie my @bar, 'TEST'; print join('|', @bar[0..3]), "\n"; EXPECT foo|fee|fie|foe +######## +package TH; +sub TIEHASH { bless {}, TH } +sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } +tie %h, TH; +eval { $h{A} = 1; print "never\n"; }; +print $@; +eval { $h{B} = 2; }; +print $@; +EXPECT +A 1 +bar +B 2 +bar diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index fdb4e34..ba0a4c2 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -1,11 +1,29 @@ #!./perl -print "1..29\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +use warnings; +print "1..49\n"; # XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +{ + no warnings 'uninitialized'; + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} + +# these shouldn't hang +{ + no warnings; + sort { for ($_ = 0;; $_++) {} } @a; + sort { while(1) {} } @a; + sort { while(1) { last; } } @a; + sort { while(0) { last; } } @a; +} -sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -31,129 +49,224 @@ $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; print "# 1: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 1\n" : "not ok 1\n"); -$x = join('', sort( backwards @harry)); +$x = join('', sort( Backwards @harry)); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( Backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); -$sub = 'backwards'; +$sub = 'Backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'Backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; -$^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail -eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); -*twoface = sub { *twoface = *backwards; $a <=> $b }; +{ + no warnings 'redefine'; + *twoface = sub { *twoface = *Backwards; $a <=> $b }; +} eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); -*twoface = sub { +{ + no warnings 'redefine'; + *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; +} eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; - my @result = sort main'backwards 'one', 'two'; + my @result = sort main'Backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { - my $sortsub = \&backwards; - my $sortglob = *backwards; - my $sortglobr = \*backwards; - my $sortname = 'backwards'; + my $sortsub = \&Backwards; + my $sortglob = *Backwards; + my $sortglobr = \*Backwards; + my $sortname = 'Backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); } { - local $sortsub = \&backwards; - local $sortglob = *backwards; - local $sortglobr = \*backwards; - local $sortname = 'backwards'; + my $sortsub = \&Backwards_stacked; + my $sortglob = *Backwards_stacked; + my $sortglobr = \*Backwards_stacked; + my $sortname = 'Backwards_stacked'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); +} + +{ + local $sortsub = \&Backwards; + local $sortglob = *Backwards; + local $sortglobr = \*Backwards; + local $sortname = 'Backwards'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&Backwards_stacked; + local $sortglob = *Backwards_stacked; + local $sortglobr = \*Backwards_stacked; + local $sortname = 'Backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); +} + +## exercise sort builtins... ($a <=> $b already tested) +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { + my $dummy; # force blockness + return $b <=> $a +} @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); +print "# x = '@b'\n"; +$x = join('', sort { $a cmp $b } @harry); +$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); +print "# x = '$x'; expected = '$expected'\n"; +$x = join('', sort { $b cmp $a } @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); +print "# x = '$x'; expected = '$expected'\n"; +{ + use integer; + @b = sort { $a <=> $b } @a; + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); + print "# x = '@b'\n"; + @b = sort { $b <=> $a } @a; + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); + print "# x = '@b'\n"; + $x = join('', sort { $a cmp $b } @harry); + $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); + print "# x = '$x'; expected = '$expected'\n"; + $x = join('', sort { $b cmp $a } @harry); + $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); + print "# x = '$x'; expected = '$expected'\n"; } +# test that an optimized-away comparison block doesn't take any other +# arguments away with it +$x = join('', sort { $a <=> $b } 3, 1, 2); +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; + +# test sorting in non-main package +package Foo; +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { $b <=> $a } @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::Backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); +print "# x = '@b'\n"; diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t index 7f0acce..8b9f4ad 100755 --- a/contrib/perl5/t/op/split.t +++ b/contrib/perl5/t/op/split.t @@ -48,11 +48,9 @@ print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` } +elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` } else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } -if ($foo =~ /DCL-W-NOCOMD/) { - $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`; -} -print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n"; +print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n"; # Can we say how many fields to split to when assigning to a list? ($a,$b) = split(' ','1 2 3 4 5 6', 2); diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t index b9b4751..4d54d2c 100755 --- a/contrib/perl5/t/op/sprintf.t +++ b/contrib/perl5/t/op/sprintf.t @@ -2,9 +2,14 @@ # $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +use warnings; + print "1..4\n"; -$^W = 1; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { $w++; @@ -14,8 +19,8 @@ $SIG{__WARN__} = sub { }; $w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999); -if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) { +$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171); +if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) { print "ok 1\n"; } else { print "not ok 1 '$x'\n"; diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t index 2207b40..af4920c 100755 --- a/contrib/perl5/t/op/stat.t +++ b/contrib/perl5/t/op/stat.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; @@ -14,28 +14,45 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; +$Is_Cygwin = $^O eq 'cygwin'; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless $Is_Dosish; +$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; unlink "Op.stat.tmp"; -open(FOO, ">Op.stat.tmp"); - -# hack to make Apollo update link count: -$junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat(FOO); -if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} -if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";} -else {print "# |$mtime| vs |$ctime|\nnot ok 2\n";} - -print FOO "Now is the time for all good men to come to.\n"; -close(FOO); - -sleep 2; +if (open(FOO, ">Op.stat.tmp")) { + # hack to make Apollo update link count: + $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FOO); + if ($nlink == 1) { + print "ok 1\n"; + } + else { + print "# res=$res, nlink=$nlink.\nnot ok 1\n"; + } + if ($Is_MSWin32 or $Is_Cygwin || ($mtime && $mtime == $ctime)) { + print "ok 2\n"; + } + else { + print "# |$mtime| vs |$ctime|\nnot ok 2\n"; + } + + my $funky_FAT_timestamps = $Is_Cygwin; + + sleep 3 if $funky_FAT_timestamps; + + print FOO "Now is the time for all good men to come to.\n"; + close(FOO); + + sleep 2 unless $funky_FAT_timestamps; + +} else { + print "# open failed: $!\nnot ok 1\nnot ok 2\n"; +} -if ($Is_Dosish) { unlink "Op.stat.tmp2" } +if ($Is_Dosish) { unlink "Op.stat.tmp2"} else { `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; } @@ -50,7 +67,8 @@ elsif ($nlink == 2) else {print "# \$nlink is |$nlink|\nnot ok 3\n";} if ( $Is_Dosish - || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug + # Solaris tmpfs bug + || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris') || $cwd =~ m#/afs/# || $^O eq 'amigaos') { print "ok 4 # skipped: different semantic of mtime/ctime\n"; @@ -65,7 +83,7 @@ else { } print "#4 :$mtime: should != :$ctime:\n"; -unlink "Op.stat.tmp"; +unlink "Op.stat.tmp" or print "# unlink failed: $!\n"; if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } else { `touch Op.stat.tmp` } @@ -76,7 +94,7 @@ $Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";} if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";} -unlink 'Op.stat.tmp'; +unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; $olduid = $>; # can't test -r if uid == 0 $Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; chmod 0,'Op.stat.tmp'; @@ -93,6 +111,9 @@ foreach ((12,13,14,15,16,17)) { print "ok $_\n"; #deleted tests } +# in ms windows, Op.stat.tmp inherits owner uid from directory +# not sure about os/2, but chown is harmless anyway +eval { chown $>,'Op.stat.tmp'; 1 } or print "# $@" ; chmod 0700,'Op.stat.tmp'; if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";} if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";} @@ -149,7 +170,7 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_Dosish) { +if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { print "ok 35 # skipped: no -u\n"; goto tty_test; } @@ -184,14 +205,23 @@ unless($ENV{PERL_SKIP_TTY_TEST}) { print "ok 37\n"; } else { - unless (open(tty,"/dev/tty")) { - print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n"; + my $TTY = "/dev/tty"; + + $TTY = "/dev/ttyp0" if $^O eq 'rhapsody'; + + if (defined $TTY) { + unless (open(TTY, $TTY)) { + print STDERR "Can't open $TTY--run t/TEST outside of make.\n"; + } + if (-t TTY) {print "ok 36\n";} else {print "not ok 36\n";} + if (-c TTY) {print "ok 37\n";} else {print "not ok 37\n";} + close(TTY); + } else { # if some platform completely undefines $TTY + print "ok 36 # skipped\n"; + print "ok 37 # skipped\n"; } - if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";} - if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";} - close(tty); } - if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";} + if (! -t TTY) {print "ok 38\n";} else {print "not ok 38\n";} if (-t) {print "ok 39\n";} else {print "not ok 39\n";} } else { @@ -249,4 +279,4 @@ $_ = 'Op.stat.tmp'; if (-f) {print "ok 57\n";} else {print "not ok 57\n";} if (-f()) {print "ok 58\n";} else {print "not ok 58\n";} -unlink 'Op.stat.tmp'; +unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t index afa06ab..9757f4c 100755 --- a/contrib/perl5/t/op/subst.t +++ b/contrib/perl5/t/op/subst.t @@ -1,6 +1,12 @@ #!./perl -print "1..71\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + +print "1..84\n"; $x = 'foo'; $_ = "x"; @@ -181,7 +187,8 @@ tr/a-z/A-Z/; print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; # same as tr/A-Z/a-z/; -if ($^O eq 'os390') { # An EBCDIC variant. +if ($Config{ebcdic} eq 'define') { # EBCDIC. + no utf8; y[\301-\351][\201-\251]; } else { # Ye Olde ASCII. Or something like it. y[\101-\132][\141-\172]; @@ -305,6 +312,70 @@ s{ \d+ \b [,.;]? (?{ 'digits' }) print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n"); $_ = 'x' x 20; -s/\d*|x/<$&>/g; +s/(\d*|x)/<$1>/g; $foo = '<>' . ('<x><>' x 20) ; print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); + +$t = 'aaaaaaaaa'; + +$_ = $t; +pos = 6; +s/\Ga/xx/g; +print "not " unless $_ eq 'aaaaaaxxxxxx'; +print "ok 72\n"; + +$_ = $t; +pos = 6; +s/\Ga/x/g; +print "not " unless $_ eq 'aaaaaaxxx'; +print "ok 73\n"; + +$_ = $t; +pos = 6; +s/\Ga/xx/; +print "not " unless $_ eq 'aaaaaaxxaa'; +print "ok 74\n"; + +$_ = $t; +pos = 6; +s/\Ga/x/; +print "not " unless $_ eq 'aaaaaaxaa'; +print "ok 75\n"; + +$_ = $t; +s/\Ga/xx/g; +print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx'; +print "ok 76\n"; + +$_ = $t; +s/\Ga/x/g; +print "not " unless $_ eq 'xxxxxxxxx'; +print "ok 77\n"; + +$_ = $t; +s/\Ga/xx/; +print "not " unless $_ eq 'xxaaaaaaaa'; +print "ok 78\n"; + +$_ = $t; +s/\Ga/x/; +print "not " unless $_ eq 'xaaaaaaaa'; +print "ok 79\n"; + +$_ = 'aaaa'; +s/\ba/./g; +print "#'$_'\nnot " unless $_ eq '.aaa'; +print "ok 80\n"; + +eval q% s/a/"b"}/e %; +print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n"); +eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; +print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n"; +$x = $x = 'interp'; +eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; +print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; + +$_ = "C:/"; +s/^([a-z]:)/\u$1/ and print "not "; +print "ok 84\n"; + diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t new file mode 100755 index 0000000..e2e7c0e5 --- /dev/null +++ b/contrib/perl5/t/op/subst_amp.t @@ -0,0 +1,104 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + +print "1..13\n"; + +$_ = 'x' x 20; +s/\d*|x/<$&>/g; +$foo = '<>' . ('<x><>' x 20) ; +print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n"); + +$t = 'aaa'; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/xx/g; +print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa'; +print "ok 2\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/x/g; +print "not " unless "$_ @res" eq 'axx aaa a aaa aa'; +print "ok 3\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/xx/; +print "not " unless "$_ @res" eq 'axxa aaa a'; +print "ok 4\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/x/; +print "not " unless "$_ @res" eq 'axa aaa a'; +print "ok 5\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/xx/g; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; +print "ok 6\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x/g; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; +print "ok 7\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/xx/; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; +print "ok 8\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x/; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; +print "ok 9\n"; + +sub x2 {'xx'} +sub x1 {'x'} + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; +print "ok 10\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; +print "ok 11\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x2/e; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; +print "ok 12\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x1/e; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; +print "ok 13\n"; + diff --git a/contrib/perl5/t/op/subst_wamp.t b/contrib/perl5/t/op/subst_wamp.t new file mode 100755 index 0000000..b716b30 --- /dev/null +++ b/contrib/perl5/t/op/subst_wamp.t @@ -0,0 +1,11 @@ +#!./perl + +$dummy = defined $&; # Now we have it... +for $file ('op/subst.t', 't/op/subst.t') { + if (-r $file) { + do $file; + exit; + } +} +die "Cannot find op/subst.t or t/op/subst.t\n"; + diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t index 87efcb4..5764e67 100755 --- a/contrib/perl5/t/op/substr.t +++ b/contrib/perl5/t/op/substr.t @@ -1,12 +1,14 @@ -#!./perl -print "1..106\n"; +print "1..125\n"; #P = start of string Q = start of substr R = end of substr S = end of string -$a = 'abcdefxyz'; -BEGIN { $^W = 1 }; +BEGIN { + unshift @INC, '../lib' if -d '../lib' ; +} +use warnings ; +$a = 'abcdefxyz'; $SIG{__WARN__} = sub { if ($_[0] =~ /^substr outside of string/) { $w++; @@ -19,139 +21,198 @@ $SIG{__WARN__} = sub { } }; -sub fail { !defined(shift) && $w-- }; +sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") } + +$FATAL_MSG = '^substr outside of string' ; -print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S -print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S -print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R -print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S -print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S -print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S +ok 1, substr($a,0,3) eq 'abc'; # P=Q R S +ok 2, substr($a,3,3) eq 'def'; # P Q R S +ok 3, substr($a,6,999) eq 'xyz'; # P Q S R +$b = substr($a,999,999) ; # warn # P R Q S +ok 4, $w-- == 1 ; +eval{substr($a,999,999) = "" ; };# P R Q S +ok 5, $@ =~ /$FATAL_MSG/; +ok 6, substr($a,0,-6) eq 'abc'; # P=Q R S +ok 7, substr($a,-3,1) eq 'x'; # P Q R S $[ = 1; -print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S -print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S -print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R -print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S -print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S -print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S +ok 8, substr($a,1,3) eq 'abc' ; # P=Q R S +ok 9, substr($a,4,3) eq 'def' ; # P Q R S +ok 10, substr($a,7,999) eq 'xyz';# P Q S R +$b = substr($a,999,999) ; # warn # P R Q S +ok 11, $w-- == 1 ; +eval{substr($a,999,999) = "" ; } ; # P R Q S +ok 12, $@ =~ /$FATAL_MSG/; +ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S +ok 14, substr($a,-3,1) eq 'x' ; # P Q R S $[ = 0; substr($a,3,3) = 'XYZ'; -print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; +ok 15, $a eq 'abcXYZxyz' ; substr($a,0,2) = ''; -print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; +ok 16, $a eq 'cXYZxyz' ; substr($a,0,0) = 'ab'; -print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; +ok 17, $a eq 'abcXYZxyz' ; substr($a,0,0) = '12345678'; -print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n"; +ok 18, $a eq '12345678abcXYZxyz' ; substr($a,-3,3) = 'def'; -print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n"; +ok 19, $a eq '12345678abcXYZdef'; substr($a,-3,3) = '<'; -print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n"; +ok 20, $a eq '12345678abcXYZ<' ; substr($a,-1,1) = '12345678'; -print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; +ok 21, $a eq '12345678abcXYZ12345678' ; $a = 'abcdefxyz'; -print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S -print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S -print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q -print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S -print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S -print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S -print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S +ok 22, substr($a,6) eq 'xyz' ; # P Q R=S +ok 23, substr($a,-3) eq 'xyz' ; # P Q R=S +$b = substr($a,999,999) ; # warning # P R=S Q +ok 24, $w-- == 1 ; +eval{substr($a,999,999) = "" ; } ; # P R=S Q +ok 25, $@ =~ /$FATAL_MSG/; +ok 26, substr($a,0) eq 'abcdefxyz' ; # P=Q R=S +ok 27, substr($a,9) eq '' ; # P Q=R=S +ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S +ok 29, substr($a,-9) eq 'abcdefxyz'; # P=Q R=S $a = '54321'; -print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S -print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S -print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S -print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S -print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S -print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S -print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S -print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S -print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S -print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S -print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S -print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S -print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q -print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q -print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q -print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R - -print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S -print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S -print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S -print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R -print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S -print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S -print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S -print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R -print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S -print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S -print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R -print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S -print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S -print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S -print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S -print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R -print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S -print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S -print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S -print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R -print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S -print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S -print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S -print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S -print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S -print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S +$b = substr($a,-7, 1) ; # warn # Q R P S +ok 30, $w-- == 1 ; +eval{substr($a,-7, 1) = "" ; }; # Q R P S +ok 31, $@ =~ /$FATAL_MSG/; +$b = substr($a,-7,-6) ; # warn # Q R P S +ok 32, $w-- == 1 ; +eval{substr($a,-7,-6) = "" ; }; # Q R P S +ok 33, $@ =~ /$FATAL_MSG/; +ok 34, substr($a,-5,-7) eq ''; # R P=Q S +ok 35, substr($a, 2,-7) eq ''; # R P Q S +ok 36, substr($a,-3,-7) eq ''; # R P Q S +ok 37, substr($a, 2,-5) eq ''; # P=R Q S +ok 38, substr($a,-3,-5) eq ''; # P=R Q S +ok 39, substr($a, 2,-4) eq ''; # P R Q S +ok 40, substr($a,-3,-4) eq ''; # P R Q S +ok 41, substr($a, 5,-6) eq ''; # R P Q=S +ok 42, substr($a, 5,-5) eq ''; # P=R Q S +ok 43, substr($a, 5,-3) eq ''; # P R Q=S +$b = substr($a, 7,-7) ; # warn # R P S Q +ok 44, $w-- == 1 ; +eval{substr($a, 7,-7) = "" ; }; # R P S Q +ok 45, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7,-5) ; # warn # P=R S Q +ok 46, $w-- == 1 ; +eval{substr($a, 7,-5) = "" ; }; # P=R S Q +ok 47, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7,-3) ; # warn # P Q S Q +ok 48, $w-- == 1 ; +eval{substr($a, 7,-3) = "" ; }; # P Q S Q +ok 49, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7, 0) ; # warn # P S Q=R +ok 50, $w-- == 1 ; +eval{substr($a, 7, 0) = "" ; }; # P S Q=R +ok 51, $@ =~ /$FATAL_MSG/; + +ok 52, substr($a,-7,2) eq ''; # Q P=R S +ok 53, substr($a,-7,4) eq '54'; # Q P R S +ok 54, substr($a,-7,7) eq '54321';# Q P R=S +ok 55, substr($a,-7,9) eq '54321';# Q P S R +ok 56, substr($a,-5,0) eq ''; # P=Q=R S +ok 57, substr($a,-5,3) eq '543';# P=Q R S +ok 58, substr($a,-5,5) eq '54321';# P=Q R=S +ok 59, substr($a,-5,7) eq '54321';# P=Q S R +ok 60, substr($a,-3,0) eq ''; # P Q=R S +ok 61, substr($a,-3,3) eq '321';# P Q R=S +ok 62, substr($a,-2,3) eq '21'; # P Q S R +ok 63, substr($a,0,-5) eq ''; # P=Q=R S +ok 64, substr($a,2,-3) eq ''; # P Q=R S +ok 65, substr($a,0,0) eq ''; # P=Q=R S +ok 66, substr($a,0,5) eq '54321';# P=Q R=S +ok 67, substr($a,0,7) eq '54321';# P=Q S R +ok 68, substr($a,2,0) eq ''; # P Q=R S +ok 69, substr($a,2,3) eq '321'; # P Q R=S +ok 70, substr($a,5,0) eq ''; # P Q=R=S +ok 71, substr($a,5,2) eq ''; # P Q=S R +ok 72, substr($a,-7,-5) eq ''; # Q P=R S +ok 73, substr($a,-7,-2) eq '543';# Q P R S +ok 74, substr($a,-5,-5) eq ''; # P=Q=R S +ok 75, substr($a,-5,-2) eq '543';# P=Q R S +ok 76, substr($a,-3,-3) eq ''; # P Q=R S +ok 77, substr($a,-3,-1) eq '32';# P Q R S $a = ''; -print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S -print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S -print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R -print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R -print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S -print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S +ok 78, substr($a,-2,2) eq ''; # Q P=R=S +ok 79, substr($a,0,0) eq ''; # P=Q=R=S +ok 80, substr($a,0,1) eq ''; # P=Q=S R +ok 81, substr($a,-2,3) eq ''; # Q P=S R +ok 82, substr($a,-2) eq ''; # Q P=R=S +ok 83, substr($a,0) eq ''; # P=Q=R=S + + +ok 84, substr($a,0,-1) eq ''; # R P=Q=S +$b = substr($a,-2, 0) ; # warn # Q=R P=S +ok 85, $w-- == 1 ; +eval{substr($a,-2, 0) = "" ; }; # Q=R P=S +ok 86, $@ =~ /$FATAL_MSG/; +$b = substr($a,-2, 1) ; # warn # Q R P=S +ok 87, $w-- == 1 ; +eval{substr($a,-2, 1) = "" ; }; # Q R P=S +ok 88, $@ =~ /$FATAL_MSG/; -print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S -print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S -print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S -print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S -print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S -print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q -print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R -print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R -print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q +$b = substr($a,-2,-1) ; # warn # Q R P=S +ok 89, $w-- == 1 ; +eval{substr($a,-2,-1) = "" ; }; # Q R P=S +ok 90, $@ =~ /$FATAL_MSG/; +$b = substr($a,-2,-2) ; # warn # Q=R P=S +ok 91, $w-- == 1 ; +eval{substr($a,-2,-2) = "" ; }; # Q=R P=S +ok 92, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1,-2) ; # warn # R P=S Q +ok 93, $w-- == 1 ; +eval{substr($a, 1,-2) = "" ; }; # R P=S Q +ok 94, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1, 1) ; # warn # P=S Q R +ok 95, $w-- == 1 ; +eval{substr($a, 1, 1) = "" ; }; # P=S Q R +ok 96, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1, 0) ;# warn # P=S Q=R +ok 97, $w-- == 1 ; +eval{substr($a, 1, 0) = "" ; }; # P=S Q=R +ok 98, $@ =~ /$FATAL_MSG/; + +$b = substr($a,1) ; # warning # P=R=S Q +ok 99, $w-- == 1 ; +eval{substr($a,1) = "" ; }; # P=R=S Q +ok 100, $@ =~ /$FATAL_MSG/; my $a = 'zxcvbnm'; substr($a,2,0) = ''; -print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; +ok 101, $a eq 'zxcvbnm'; substr($a,7,0) = ''; -print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; +ok 102, $a eq 'zxcvbnm'; substr($a,5,0) = ''; -print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; +ok 103, $a eq 'zxcvbnm'; substr($a,0,2) = 'pq'; -print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; +ok 104, $a eq 'pqcvbnm'; substr($a,2,0) = 'r'; -print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; +ok 105, $a eq 'pqrcvbnm'; substr($a,8,0) = 'asd'; -print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; +ok 106, $a eq 'pqrcvbnmasd'; substr($a,0,2) = 'iop'; -print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; +ok 107, $a eq 'ioprcvbnmasd'; substr($a,0,5) = 'fgh'; -print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; +ok 108, $a eq 'fghvbnmasd'; substr($a,3,5) = 'jkl'; -print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; +ok 109, $a eq 'fghjklsd'; substr($a,3,2) = '1234'; -print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; +ok 110, $a eq 'fgh1234lsd'; # with lexicals (and in re-entered scopes) @@ -160,52 +221,50 @@ for (0,1) { unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; - print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; + ok 111, $txt eq "FoX"; } else { - local $^W = 0; # because of (spurious?) "uninitialised value" substr($txt, 0, 1) = "X"; - print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; + ok 112, $txt eq "X"; } } +$w = 0 ; # coercion of references { my $s = []; substr($s, 0, 1) = 'Foo'; - print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; + ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2); } # check no spurious warnings -print $w ? "not ok 97\n" : "ok 97\n"; +ok 114, $w == 0; # check new 4 arg replacement syntax $a = "abcxyz"; $w = 0; -print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; -print "ok 98\n"; -print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; -print "ok 99\n"; -print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; -print "ok 100\n"; - -print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" +ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; + +ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" && $w == 3; -print "ok 101\n"; + $w = 0; -print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; -print "ok 102\n"; -print "not " unless fail(substr($a, -99, 0, "")); -print "ok 103\n"; -print "not " unless fail(substr($a, 99, 3, "")); -print "ok 104\n"; +ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; +eval{substr($a, -99, 0, "") }; +ok 120, $@ =~ /$FATAL_MSG/; +eval{substr($a, 99, 3, "") }; +ok 121, $@ =~ /$FATAL_MSG/; substr($a, 0, length($a), "foo"); -print "not " unless $a eq "foo" && !$w; -print "ok 105\n"; +ok 122, $a eq "foo" && !$w; # using 4 arg substr as lvalue is a compile time error eval 'substr($a,0,0,"") = "abc"'; -print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; -print "ok 106\n"; +ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; + +$a = "abcdefgh"; +ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; +ok 125, $a eq 'xxxxefgh'; diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t index 22e60e3..e43f850 100755 --- a/contrib/perl5/t/op/sysio.t +++ b/contrib/perl5/t/op/sysio.t @@ -2,7 +2,7 @@ print "1..39\n"; -chdir('op') || die "sysio.t: cannot look for myself: $!"; +chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!"; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index 379093f..6548b46 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use strict; @@ -19,6 +19,17 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +BEGIN { + if ($^O eq 'VMS' && !defined($Config{d_setenv})) { + $ENV{PATH} = $ENV{PATH}; + $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; + } + if ($Config{d_shm} || $Config{d_msg}) { + require IPC::SysV; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } +} + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -33,9 +44,9 @@ if ($Is_VMS) { } eval <<EndOfCleanup; END { - \$ENV{PATH} = ''; + \$ENV{PATH} = '' if $Config{d_setenv}; warn "# Note: logical name 'PATH' may have been deleted\n"; - @ENV{keys %old} = values %old; + \@ENV{keys %old} = values %old; } EndOfCleanup } @@ -87,7 +98,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..149\n"; +print "1..151\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -130,7 +141,7 @@ print "1..149\n"; } else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(/tmp /var/tmp /usr/tmp /sys$scratch), + qw(sys$scratch /tmp /var/tmp /usr/tmp), @ENV{qw(TMP TEMP)})[0] or print "# can't find world-writeable directory to test PATH\n"; } @@ -247,7 +258,8 @@ print "1..149\n"; # Globs should be forbidden, except under VMS, # which doesn't spawn an external program. -if ($Is_VMS) { +if (1 # built-in glob + or $Is_VMS) { for (35..36) { print "ok $_\n"; } } else { @@ -383,10 +395,10 @@ else { for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" } } else { - test 76, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 76, eval { open FOO, "| x$foo" } eq '', 'popen to'; test 77, $@ =~ /^Insecure dependency/, $@; - test 78, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 78, eval { open FOO, "x$foo |" } eq '', 'popen from'; test 79, $@ =~ /^Insecure dependency/, $@; } @@ -539,14 +551,14 @@ else { my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); test 142,( not tainted $getpwent[0] - and not tainted $getpwent[1] + and tainted $getpwent[1] and not tainted $getpwent[2] and not tainted $getpwent[3] and not tainted $getpwent[4] and not tainted $getpwent[5] - and tainted $getpwent[6] # gecos + and tainted $getpwent[6] # ge?cos and not tainted $getpwent[7] - and not tainted $getpwent[8]); + and tainted $getpwent[8]); # shell endpwent(); } else { for (142) { print "ok $_ # Skipped: getpwent() is not available\n" } @@ -597,3 +609,74 @@ else { $why =~ s/e/'-'.$$/ge; test 149, tainted $why; } + +# test shmread +{ + if ($Config{d_shm}) { + no strict 'subs'; + my $sent = "foobar"; + my $rcvd; + my $size = 2000; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || + warn "# shmget failed: $!\n"; + if (defined $id) { + if (shmwrite($id, $sent, 0, 60)) { + if (shmread($id, $rcvd, 0, 60)) { + substr($rcvd, index($rcvd, "\0")) = ''; + } else { + warn "# shmread failed: $!\n"; + } + } else { + warn "# shmwrite failed: $!\n"; + } + shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + } else { + warn "# shmget failed: $!\n"; + } + + if ($rcvd eq $sent) { + test 150, tainted $rcvd; + } else { + print "ok 150 # Skipped: SysV shared memory operation failed\n"; + } + } else { + print "ok 150 # Skipped: SysV shared memory is not available\n"; + } +} + +# test msgrcv +{ + if ($Config{d_msg}) { + no strict 'subs'; + my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); + + my $sent = "message"; + my $type_sent = 1234; + my $rcvd; + my $type_rcvd; + + if (defined $id) { + if (msgsnd($id, pack("l! a*", $type_sent, $sent), 0)) { + if (msgrcv($id, $rcvd, 60, 0, 0)) { + ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); + } else { + warn "# msgrcv failed\n"; + } + } else { + warn "# msgsnd failed\n"; + } + msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + } else { + warn "# msgget failed\n"; + } + + if ($rcvd eq $sent && $type_sent == $type_rcvd) { + test 151, tainted $rcvd; + } else { + print "ok 151 # Skipped: SysV message queue operation failed\n"; + } + } else { + print "ok 151 # Skipped: SysV message queues are not available\n"; + } +} + diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 472a6a7..9543420 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -6,7 +6,7 @@ # Currently it only tests the untie warning chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -77,8 +77,7 @@ EXPECT ######## # strict behaviour, without any extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -86,8 +85,7 @@ EXPECT ######## # strict behaviour, with 1 extra references generating an error -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; @@ -96,8 +94,7 @@ untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references via tied generating an error -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -107,8 +104,7 @@ untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references which are destroyed -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -117,8 +113,7 @@ EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -128,8 +123,7 @@ EXPECT ######## # strict error behaviour, with 2 extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; @@ -139,14 +133,12 @@ untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. -#no warning 'untie'; -local $^W = 0 ; +no warnings 'untie'; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { - #use warning 'untie'; - local $^W = 1 ; + use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -166,3 +158,15 @@ sub Self::DESTROY { $b = $_[0] + 0; } } die unless $a == $b; EXPECT +######## +# Interaction of tie and vec + +my ($a, $b); +use Tie::Scalar; +tie $a,Tie::StdScalar or die; +vec($b,1,1)=1; +$a = $b; +vec($a,1,1)=0; +vec($b,1,1)=0; +die unless $a eq $b; +EXPECT diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t index 8e78b2f..25fda3f 100755 --- a/contrib/perl5/t/op/tiearray.t +++ b/contrib/perl5/t/op/tiearray.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my %seen; diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index d7e6a78..6ae3faa 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my @expect; diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t index 1bec442..caf2c14 100755 --- a/contrib/perl5/t/op/time.t +++ b/contrib/perl5/t/op/time.t @@ -2,7 +2,7 @@ # $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ -if ($does_gmtime = gmtime(time)) { print "1..5\n" } +if ($does_gmtime = gmtime(time)) { print "1..6\n" } else { print "1..3\n" } ($beguser,$begsys) = times; @@ -45,3 +45,9 @@ if (index(" :0:1:-1:364:365:-364:-365:",':' . ($localyday - $yday) . ':') > 0) {print "ok 5\n";} else {print "not ok 5\n";} + +# This could be stricter. +if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/) + {print "ok 6\n";} +else + {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t index 3503c3c..4e6667c 100755 --- a/contrib/perl5/t/op/tr.t +++ b/contrib/perl5/t/op/tr.t @@ -1,5 +1,10 @@ # tr.t +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib"; +} + print "1..4\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -22,12 +27,13 @@ print "ok 3\n"; # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. # Yes, discontinuities. Regardless, the \xca in the below should stay # untouched (and not became \x8a). +{ + no utf8; + $_ = "I\xcaJ"; -$_ = "I\xcaJ"; - -tr/I-J/i-j/; - -print "not " unless $_ eq "i\xcaj"; -print "ok 4\n"; + tr/I-J/i-j/; + print "not " unless $_ eq "i\xcaj"; + print "ok 4\n"; +} # diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 5b3c7ef..8944ee3 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -1,6 +1,11 @@ #!./perl -print "1..23\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..27\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -59,3 +64,18 @@ print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n"; eval { $1 = undef }; print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n"; +{ + require Tie::Hash; + tie my %foo, 'Tie::StdHash'; + print defined %foo ? "ok 24\n" : "not ok 24\n"; + %foo = ( a => 1 ); + print defined %foo ? "ok 25\n" : "not ok 25\n"; +} + +{ + require Tie::Array; + tie my @foo, 'Tie::StdArray'; + print defined @foo ? "ok 26\n" : "not ok 26\n"; + @foo = ( a => 1 ); + print defined @foo ? "ok 27\n" : "not ok 27\n"; +} diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t index bde78fd..a6bd03d 100755 --- a/contrib/perl5/t/op/universal.t +++ b/contrib/perl5/t/op/universal.t @@ -5,10 +5,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } -print "1..72\n"; +print "1..73\n"; $a = {}; bless $a, "Bob"; @@ -70,7 +70,7 @@ test ! $a->can("export_tags"); # a method in Exporter test (eval { $a->VERSION }) == 2.718; test ! (eval { $a->VERSION(2.719) }) && - $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; + $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; test (eval { $a->VERSION(2.718) }) && ! $@; @@ -102,3 +102,5 @@ test $a->can("sleep"); test ! UNIVERSAL::can($b, "can"); test ! $a->can("export_tags"); # a method in Exporter + +test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t index 7117144..bf60fc4 100755 --- a/contrib/perl5/t/op/vec.t +++ b/contrib/perl5/t/op/vec.t @@ -8,7 +8,7 @@ print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; vec($foo,0,1) = 1; print length($foo) == 1 ? "ok 3\n" : "not ok 3\n"; -print ord($foo) == 1 ? "ok 4\n" : "not ok 4\n"; +print unpack('C',$foo) == 1 ? "ok 4\n" : "not ok 4\n"; print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n"; print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n"; @@ -18,7 +18,7 @@ print length($foo) == 3 ? "ok 8\n" : "not ok 8\n"; print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n"; vec($foo,1,8) = 0xf1; print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; -print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); +print ((unpack('C',substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; vec($Vec, 0, 32) = 0xbaddacab; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t new file mode 100755 index 0000000..b08849f --- /dev/null +++ b/contrib/perl5/t/op/ver.t @@ -0,0 +1,96 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib"; +} + +print "1..22\n"; + +my $test = 1; + +use v5.5.640; +require v5.5.640; +print "ok $test\n"; ++$test; + +# printing characters should work +print v111; +print v107.32; +print "$test\n"; ++$test; + +# hash keys too +$h{v111.107} = "ok"; +print "$h{ok} $test\n"; ++$test; + +# poetry optimization should also +sub v77 { "ok" } +$x = v77; +print "$x $test\n"; ++$test; + +# but not when dots are involved +$x = v77.78.79; +print "not " unless $x eq "MNO"; +print "ok $test\n"; ++$test; + +print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; +print "ok $test\n"; ++$test; + +# +# now do the same without the "v" +use 5.5.640; +require 5.5.640; +print "ok $test\n"; ++$test; + +# hash keys too +$h{111.107.32} = "ok"; +print "$h{ok } $test\n"; ++$test; + +$x = 77.78.79; +print "not " unless $x eq "MNO"; +print "ok $test\n"; ++$test; + +print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; +print "ok $test\n"; ++$test; + +# test sprintf("%vd"...) etc +print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%*vb", "##", v1.22.333.4444) + eq '1##10110##101001101##1000101011100'; +print "ok $test\n"; ++$test; + +{ + use bytes; + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + print "ok $test\n"; ++$test; + + print "not " unless + sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%*vb", "##", v1.22.333.4444) + eq '1##10110##11000101##10001101##11100001##10000101##10011100'; + print "ok $test\n"; ++$test; +} diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 9918b2f..87d5042 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ - -print "1..6\n"; +print "1..8\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -190,3 +188,16 @@ if (`$CAT Op_write.tmp` eq $right) else { print "not ok 6\n"; } +# test lexicals and globals +{ + my $this = "ok"; + our $that = 7; + format LEX = +@<<@| +$this,$that +. + open(LEX, ">&STDOUT") or die; + write LEX; + $that = 8; + write LEX; +} diff --git a/contrib/perl5/t/pod/emptycmd.t b/contrib/perl5/t/pod/emptycmd.t new file mode 100755 index 0000000..d348a9d --- /dev/null +++ b/contrib/perl5/t/pod/emptycmd.t @@ -0,0 +1,21 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +__END__ + +=pod + += this is a test +of the emergency +broadcast system + +=cut diff --git a/contrib/perl5/t/pod/emptycmd.xr b/contrib/perl5/t/pod/emptycmd.xr new file mode 100644 index 0000000..f06d2db --- /dev/null +++ b/contrib/perl5/t/pod/emptycmd.xr @@ -0,0 +1,2 @@ + = this is a test of the emergency broadcast system + diff --git a/contrib/perl5/t/pod/for.t b/contrib/perl5/t/pod/for.t new file mode 100755 index 0000000..b8a6ec5 --- /dev/null +++ b/contrib/perl5/t/pod/for.t @@ -0,0 +1,59 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test + +=for theloveofpete +You shouldn't see this +or this +or this + +=for text +pod2text should see this +and this +and this + +and everything should see this! + +=begin text + +Similarly, this line ... + +and this one ... + +as well this one, + +should all be in pod2text output + +=end text + +Tweedley-deedley-dee, Im as happy as can be! +Tweedley-deedley-dum, cuz youre my honey sugar plum! + +=begin atthebeginning + +But I expect to see neither hide ... + +nor tail ... + +of this text + +=end atthebeginning + +The rest of this should show up in everything. + diff --git a/contrib/perl5/t/pod/for.xr b/contrib/perl5/t/pod/for.xr new file mode 100644 index 0000000..5f6b8b2 --- /dev/null +++ b/contrib/perl5/t/pod/for.xr @@ -0,0 +1,21 @@ + This is a test + + pod2text should see this + and this + and this + + and everything should see this! + +Similarly, this line ... + +and this one ... + +as well this one, + +should all be in pod2text output + + Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz + youre my honey sugar plum! + + The rest of this should show up in everything. + diff --git a/contrib/perl5/t/pod/headings.t b/contrib/perl5/t/pod/headings.t new file mode 100755 index 0000000..fc7b4b2 --- /dev/null +++ b/contrib/perl5/t/pod/headings.t @@ -0,0 +1,140 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +################################################################# + use Pod::Usage; + pod2usage( VERBOSE => 2, EXIT => 1 ); + +=pod + +=head1 NAME + +B<rdb2pg> - insert an rdb table into a PostgreSQL database + +=head1 SYNOPSIS + +B<rdb2pg> [I<param>=I<value> ...] + +=head1 PARAMETERS + +B<rdb2pg> uses an IRAF-compatible parameter interface. +A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. + +=over 4 + +=item B<input> I<file> + +The B<RDB> file to insert into the database. If the given name +is the string C<stdin>, it reads from the UNIX standard input stream. + + +=back + +=head1 DESCRIPTION + +B<rdb2pg> will enter the data from an B<RDB> database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B<RDB> file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C<db> and C<table> +parameters. If they do not exist, and the C<createdb> parameter is +set, they will be created. Table field definitions are determined +in the following order: + +=cut + +################################################################# + +results in: + + +################################################################# + + rdb2pg - insert an rdb table into a PostgreSQL database + + rdb2pg [*param*=*value* ...] + + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + The RDB file to insert into the database. If the given name is + the string `stdin', it reads from the UNIX standard input + stream. + + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + +while the original version of Text (using pod2text) gives + +################################################################# + +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template + parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name + is the string `stdin', it reads from the UNIX standard input + stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a + PostgreSQL database table, optionally creating the database and + the table if they do not exist. It automatically determines the + PostgreSQL data type from the column definition in the RDB file, + but may be overriden via a series of definition files or + directly via one of its parameters. + + The target database and table are specified by the `db' and + `table' parameters. If they do not exist, and the `createdb' + parameter is set, they will be created. Table field definitions + are determined in the following order: + + +################################################################# + + +Thanks for any help. If, as your email indicates, you've not much +time to look at this, I can work around things by calling pod2text() +directly using the official Text.pm. + +Diab + +------------- +Diab Jerius +djerius@cfa.harvard.edu + diff --git a/contrib/perl5/t/pod/headings.xr b/contrib/perl5/t/pod/headings.xr new file mode 100644 index 0000000..fb37a2b --- /dev/null +++ b/contrib/perl5/t/pod/headings.xr @@ -0,0 +1,26 @@ +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. + + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: + diff --git a/contrib/perl5/t/pod/include.t b/contrib/perl5/t/pod/include.t new file mode 100755 index 0000000..6d0b7e3 --- /dev/null +++ b/contrib/perl5/t/pod/include.t @@ -0,0 +1,36 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This file tries to demonstrate a simple =include directive +for pods. It is used as follows: + + =include filename + +where "filename" is expected to be an absolute pathname, or else +reside be relative to the directory in which the current processed +podfile resides, or be relative to the current directory. + +Lets try it out with the file "included.t" shall we. + +***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +=include included.t + +***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + +So how did we do??? diff --git a/contrib/perl5/t/pod/include.xr b/contrib/perl5/t/pod/include.xr new file mode 100644 index 0000000..624ee44 --- /dev/null +++ b/contrib/perl5/t/pod/include.xr @@ -0,0 +1,22 @@ + This file tries to demonstrate a simple =include directive for pods. It + is used as follows: + + =include filename + + where "filename" is expected to be an absolute pathname, or else reside + be relative to the directory in which the current processed podfile + resides, or be relative to the current directory. + + Lets try it out with the file "included.t" shall we. + + ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** + +###### begin =include included.t ##### + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx + +###### end =include included.t ##### + ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** + + So how did we do??? + diff --git a/contrib/perl5/t/pod/included.t b/contrib/perl5/t/pod/included.t new file mode 100755 index 0000000..0e31a09 --- /dev/null +++ b/contrib/perl5/t/pod/included.t @@ -0,0 +1,35 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +##------------------------------------------------------------ +# This file is =included by "include.t" +# +# This text should NOT be in the resultant pod document +# because we havent seen an =xxx pod directive in this file! +##------------------------------------------------------------ + +=pod + +This is the text of the included file named "included.t". +It should appear in the final pod document from pod2xxx + +=cut + +##------------------------------------------------------------ +# This text should NOT be in the resultant pod document +# because it is *after* an =cut an no other pod directives +# proceed it! +##------------------------------------------------------------ diff --git a/contrib/perl5/t/pod/included.xr b/contrib/perl5/t/pod/included.xr new file mode 100644 index 0000000..54142fa --- /dev/null +++ b/contrib/perl5/t/pod/included.xr @@ -0,0 +1,3 @@ + This is the text of the included file named "included.t". It should + appear in the final pod document from pod2xxx + diff --git a/contrib/perl5/t/pod/lref.t b/contrib/perl5/t/pod/lref.t new file mode 100755 index 0000000..e367d6d --- /dev/null +++ b/contrib/perl5/t/pod/lref.t @@ -0,0 +1,66 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +Try out I<LOTS> of different ways of specifying references: + +Reference the L<manpage/section> + +Reference the L<manpage / section> + +Reference the L<manpage/ section> + +Reference the L<manpage /section> + +Reference the L<"manpage/section"> + +Reference the L<"manpage"/section> + +Reference the L<manpage/"section"> + +Reference the L<manpage/ +section> + +Reference the L<manpage +/section> + +Now try it using the new "|" stuff ... + +Reference the L<thistext|manpage/section> + +Reference the L<thistext | manpage / section> + +Reference the L<thistext| manpage/ section> + +Reference the L<thistext |manpage /section> + +Reference the L<thistext| +"manpage/section"> + +Reference the L<thistext +|"manpage"/section> + +Reference the L<thistext|manpage/"section"> + +Reference the L<thistext| +manpage/ +section> + +Reference the L<thistext +|manpage +/section> + diff --git a/contrib/perl5/t/pod/lref.xr b/contrib/perl5/t/pod/lref.xr new file mode 100644 index 0000000..297053b --- /dev/null +++ b/contrib/perl5/t/pod/lref.xr @@ -0,0 +1,40 @@ + Try out *LOTS* of different ways of specifying references: + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section on "manpage/section" + + Reference the the section entry in the "manpage" manpage + + Reference the the section on "section" in the manpage manpage + + Reference the the section entry in the manpage manpage + + Reference the the section entry in the manpage manpage + + Now try it using the new "|" stuff ... + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + + Reference the thistext + diff --git a/contrib/perl5/t/pod/multiline_items.t b/contrib/perl5/t/pod/multiline_items.t new file mode 100755 index 0000000..37e8d53 --- /dev/null +++ b/contrib/perl5/t/pod/multiline_items.t @@ -0,0 +1,31 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test multiline item lists + +This is a test to ensure that multiline =item paragraphs +get indented appropriately. + +=over 4 + +=item This +is +a +test. + +=back + +=cut diff --git a/contrib/perl5/t/pod/multiline_items.xr b/contrib/perl5/t/pod/multiline_items.xr new file mode 100644 index 0000000..dddf05f --- /dev/null +++ b/contrib/perl5/t/pod/multiline_items.xr @@ -0,0 +1,5 @@ +Test multiline item lists + This is a test to ensure that multiline =item paragraphs get indented + appropriately. + + This is a test. diff --git a/contrib/perl5/t/pod/nested_items.t b/contrib/perl5/t/pod/nested_items.t new file mode 100755 index 0000000..9c09801 --- /dev/null +++ b/contrib/perl5/t/pod/nested_items.t @@ -0,0 +1,64 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=head1 Test nested item lists + +This is a test to ensure the nested =item paragraphs +get indented appropriately. + +=over 2 + +=item 1 + +First section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=back + +=item 2 + +Second section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=item c + +=item d + +This is item c & d. + +=back + +=back + +=cut diff --git a/contrib/perl5/t/pod/nested_items.xr b/contrib/perl5/t/pod/nested_items.xr new file mode 100644 index 0000000..dd1adac --- /dev/null +++ b/contrib/perl5/t/pod/nested_items.xr @@ -0,0 +1,19 @@ +Test nested item lists + This is a test to ensure the nested =item paragraphs get indented + appropriately. + + 1 First section. + + a this is item a + + b this is item b + + 2 Second section. + + a this is item a + + b this is item b + + c + d This is item c & d. + diff --git a/contrib/perl5/t/pod/nested_seqs.t b/contrib/perl5/t/pod/nested_seqs.t new file mode 100755 index 0000000..6a5405b --- /dev/null +++ b/contrib/perl5/t/pod/nested_seqs.t @@ -0,0 +1,23 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +The statement: C<This is dog kind's I<finest> hour!> is a parody of a +quotation from Winston Churchill. + +=cut + diff --git a/contrib/perl5/t/pod/nested_seqs.xr b/contrib/perl5/t/pod/nested_seqs.xr new file mode 100644 index 0000000..f981061 --- /dev/null +++ b/contrib/perl5/t/pod/nested_seqs.xr @@ -0,0 +1,3 @@ + The statement: `This is dog kind's *finest* hour!' is a parody of a + quotation from Winston Churchill. + diff --git a/contrib/perl5/t/pod/oneline_cmds.t b/contrib/perl5/t/pod/oneline_cmds.t new file mode 100755 index 0000000..3081ef4 --- /dev/null +++ b/contrib/perl5/t/pod/oneline_cmds.t @@ -0,0 +1,46 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +==head1 NAME +B<rdb2pg> - insert an rdb table into a PostgreSQL database + +==head1 SYNOPSIS +B<rdb2pg> [I<param>=I<value> ...] + +==head1 PARAMETERS +B<rdb2pg> uses an IRAF-compatible parameter interface. +A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. + +==over 4 +==item B<input> I<file> +The B<RDB> file to insert into the database. If the given name +is the string C<stdin>, it reads from the UNIX standard input stream. + +==back + +==head1 DESCRIPTION +B<rdb2pg> will enter the data from an B<RDB> database into a +PostgreSQL database table, optionally creating the database and the +table if they do not exist. It automatically determines the +PostgreSQL data type from the column definition in the B<RDB> file, +but may be overriden via a series of definition files or directly +via one of its parameters. + +The target database and table are specified by the C<db> and C<table> +parameters. If they do not exist, and the C<createdb> parameter is +set, they will be created. Table field definitions are determined +in the following order: + diff --git a/contrib/perl5/t/pod/oneline_cmds.xr b/contrib/perl5/t/pod/oneline_cmds.xr new file mode 100644 index 0000000..fb37a2b --- /dev/null +++ b/contrib/perl5/t/pod/oneline_cmds.xr @@ -0,0 +1,26 @@ +NAME + rdb2pg - insert an rdb table into a PostgreSQL database + +SYNOPSIS + rdb2pg [*param*=*value* ...] + +PARAMETERS + rdb2pg uses an IRAF-compatible parameter interface. A template parameter + file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. + + input *file* + The RDB file to insert into the database. If the given name is the + string `stdin', it reads from the UNIX standard input stream. + +DESCRIPTION + rdb2pg will enter the data from an RDB database into a PostgreSQL + database table, optionally creating the database and the table if they + do not exist. It automatically determines the PostgreSQL data type from + the column definition in the RDB file, but may be overriden via a series + of definition files or directly via one of its parameters. + + The target database and table are specified by the `db' and `table' + parameters. If they do not exist, and the `createdb' parameter is set, + they will be created. Table field definitions are determined in the + following order: + diff --git a/contrib/perl5/t/pod/pod2usage.t b/contrib/perl5/t/pod/pod2usage.t new file mode 100755 index 0000000..bceeeef --- /dev/null +++ b/contrib/perl5/t/pod/pod2usage.t @@ -0,0 +1,18 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include pod2usage.PL + + diff --git a/contrib/perl5/t/pod/pod2usage.xr b/contrib/perl5/t/pod/pod2usage.xr new file mode 100644 index 0000000..7315d40 --- /dev/null +++ b/contrib/perl5/t/pod/pod2usage.xr @@ -0,0 +1,55 @@ +###### begin =include pod2usage.PL ##### +NAME + pod2usage - print usage messages from embedded pod docs in files + +SYNOPSIS + pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*] + [-verbose *level*] [-pathlist *dirlist*] *file* + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print this command's manual page and exit. + + -exit *exitval* + The exit status value to return. + + -output *outfile* + The output file to print to. If the special names "-" or ">&1" + or ">&STDOUT" are used then standard output is used. If ">&2" or + ">&STDERR" is used then standard error is used. + + -verbose *level* + The desired level of verbosity to use: + + 1 : print SYNOPSIS only + 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections + 3 : print the entire manpage (similar to running pod2text) + + -pathlist *dirlist* + Specifies one or more directories to search for the input file + if it was not supplied with an absolute path. Each directory + path in the given list should be separated by a ':' on Unix (';' + on MSWin32 and DOS). + + *file* The pathname of a file containing pod documentation to be output + in usage mesage format (defaults to standard input). + +DESCRIPTION + pod2usage will read the given input file looking for pod documentation + and will print the corresponding usage message. If no input file is + specifed than standard input is read. + + pod2usage invokes the pod2usage() function in the Pod::Usage module. + Please see the pod2usage() entry in the Pod::Usage manpage. + +SEE ALSO + the Pod::Usage manpage, the pod2text(1) manpage + +AUTHOR + Brad Appleton <bradapp@enteract.com> + + Based on code for pod2text(1) written by Tom Christiansen + <tchrist@mox.perl.com> + +###### end =include pod2usage.PL ##### diff --git a/contrib/perl5/t/pod/poderrs.t b/contrib/perl5/t/pod/poderrs.t new file mode 100755 index 0000000..ec632c2 --- /dev/null +++ b/contrib/perl5/t/pod/poderrs.t @@ -0,0 +1,125 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testpchk.pl"; + import TestPodChecker; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodchecker \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + +### Deliberately throw in some blank but non-empty lines + +### The above line should contain spaces + + +__END__ + + +=head1 NAME + +poderrors.t - test Pod::Checker on some pod syntax errors + +=unknown1 this is an unknown command with two N<unknownA> +and D<unknownB> interior sequences. + +This is some paragraph text with some unknown interior sequences, +such as Q<unknown2>, +A<unknown3>, +and Y<unknown4 V<unknown5>>. + +Now try some unterminated sequences like +I<hello mudda! +B<hello fadda! + +Here I am at C<camp granada! + +Camps is very, +entertaining. +And they say we'll have some fun if it stops raining! + +Okay, now use a non-empty blank line to terminate a paragraph and make +sure we get a warning. + +The above blank line contains tabs and spaces only + +=head1 Additional tests + +=head2 item without over + +=item oops + +=head2 back without over + +=back + +=head2 over without back + +=over 4 + +=item oops + +=head2 end without begin + +=end + +=head2 begin and begin + +=begin html + +=begin text + +=end + +=end + +=head2 Nested sequences of the same type + +C<code I<italic C<code again!>>> + +=head2 Garbled entities + +E<alea iacta est> +E<C<auml>> +E<abcI<bla>> + +=head2 Unresolved internal links + +L</"begin or begin"> +L<"end with begin"> +L</OoPs> + +=head2 Some links with problems + +L<abc +def> +L<> +L<"Warnings"> this one is ok + +=head2 Warnings + +L<passwd(5)> +L< some text|page/"section" > + +=over 4 + +=item bla + +=back 200 + +=begin html + +What? + +=end xml + +=over 4 + +=back + +see these unescaped < and > in the text? + +=cut + diff --git a/contrib/perl5/t/pod/poderrs.xr b/contrib/perl5/t/pod/poderrs.xr new file mode 100644 index 0000000..b8e5e86 --- /dev/null +++ b/contrib/perl5/t/pod/poderrs.xr @@ -0,0 +1,33 @@ +*** ERROR: Unknown command 'unknown1' at line 25 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Q' at line 29 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'A' at line 30 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'Y' at line 31 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence 'V' at line 31 in file pod/poderrs.t +*** ERROR: unterminated B<...> at line 35 in file pod/poderrs.t +*** ERROR: unterminated I<...> at line 34 in file pod/poderrs.t +*** ERROR: unterminated C<...> at line 37 in file pod/poderrs.t +*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file pod/poderrs.t +*** ERROR: =item without previous =over at line 52 in file pod/poderrs.t +*** ERROR: =back without previous =over at line 56 in file pod/poderrs.t +*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file pod/poderrs.t +*** ERROR: =end without =begin at line 66 in file pod/poderrs.t +*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file pod/poderrs.t +*** ERROR: =end without =begin at line 76 in file pod/poderrs.t +*** ERROR: nested commands C<...C<...>...> at line 80 in file pod/poderrs.t +*** ERROR: garbled entity E<alea iacta est> at line 84 in file pod/poderrs.t +*** ERROR: garbled entity E<C<auml>> at line 85 in file pod/poderrs.t +*** ERROR: garbled entity E<abcI<bla>> at line 86 in file pod/poderrs.t +*** WARNING: collapsing newlines to blanks at line 96 in file pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 98 in file pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 104 in file pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 104 in file pod/poderrs.t +*** ERROR: Spurious character(s) after =back at line 110 in file pod/poderrs.t +*** WARNING: No items in =over (at line 118) / =back list at line 120 in file pod/poderrs.t +*** WARNING: 2 unescaped <> in paragraph at line 122 in file pod/poderrs.t +*** ERROR: unresolved internal link 'begin or begin' at line 90 in file pod/poderrs.t +*** ERROR: unresolved internal link 'end with begin' at line 91 in file pod/poderrs.t +*** ERROR: unresolved internal link 'OoPs' at line 92 in file pod/poderrs.t +*** ERROR: unresolved internal link 'abc def' at line 96 in file pod/poderrs.t +*** ERROR: unresolved internal link 'passwd(5)' at line 103 in file pod/poderrs.t +*** WARNING: multiple occurence of link target 'oops' at line - in file pod/poderrs.t +pod/poderrs.t has 25 pod syntax errors. diff --git a/contrib/perl5/t/pod/podselect.t b/contrib/perl5/t/pod/podselect.t new file mode 100755 index 0000000..30eb30c --- /dev/null +++ b/contrib/perl5/t/pod/podselect.t @@ -0,0 +1,18 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + +=include podselect.PL + + diff --git a/contrib/perl5/t/pod/podselect.xr b/contrib/perl5/t/pod/podselect.xr new file mode 100644 index 0000000..7d1188d --- /dev/null +++ b/contrib/perl5/t/pod/podselect.xr @@ -0,0 +1,42 @@ +###### begin =include podselect.PL ##### +NAME + podselect - print selected sections of pod documentation on standard + output + +SYNOPSIS + podselect [-help] [-man] [-section *section-spec*] [*file* ...] + +OPTIONS AND ARGUMENTS + -help Print a brief help message and exit. + + -man Print the manual page and exit. + + -section *section-spec* + Specify a section to include in the output. See the section on + "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the + format to use for *section-spec*. This option may be given + multiple times on the command line. + + *file* The pathname of a file from which to select sections of pod + documentation (defaults to standard input). + +DESCRIPTION + podselect will read the given input files looking for pod documentation + and will print out (in raw pod format) all sections that match one ore + more of the given section specifications. If no section specifications + are given than all pod sections encountered are output. + + podselect invokes the podselect() function exported by Pod::Select + Please see the podselect() entry in the Pod::Select manpage for more + details. + +SEE ALSO + the Pod::Parser manpage and the Pod::Select manpage + +AUTHOR + Brad Appleton <bradapp@enteract.com> + + Based on code for Pod::Text::pod2text(1) written by Tom Christiansen + <tchrist@mox.perl.com> + +###### end =include podselect.PL ##### diff --git a/contrib/perl5/t/pod/special_seqs.t b/contrib/perl5/t/pod/special_seqs.t new file mode 100755 index 0000000..b8af57e --- /dev/null +++ b/contrib/perl5/t/pod/special_seqs.t @@ -0,0 +1,43 @@ +#!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, './pod', '../lib'; + require "testp2pt.pl"; + import TestPodIncPlainText; +} + +my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash +my $passed = testpodplaintext \%options, $0; +exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; + + +__END__ + + +=pod + +This is a test to see if I can do not only C<$self> and C<method()>, but +also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and +C<< $Foo <=> $Bar >> without resorting to escape sequences. If +I want to refer to the right-shift operator I can do something +like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>. + +Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>. +And I also want to make sure that newlines work like this +C<<< +$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b] +>>> + +Of course I should still be able to do all this I<with> escape sequences +too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and C<{FOO=E<gt>BAR}>. + +Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>. + +And make sure that C<0> works too! + +Now, if I use << or >> as my delimiters, then I have to use whitespace. +So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end +up doing what you might expect since the first > will still terminate +the first < seen. + +=cut diff --git a/contrib/perl5/t/pod/special_seqs.xr b/contrib/perl5/t/pod/special_seqs.xr new file mode 100644 index 0000000..a07f4cf --- /dev/null +++ b/contrib/perl5/t/pod/special_seqs.xr @@ -0,0 +1,22 @@ + This is a test to see if I can do not only `$self' and `method()', but + also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar' + without resorting to escape sequences. If I want to refer to the + right-shift operator I can do something like `$x >> 3' or even `$y >> + 5'. + + Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'. + And I also want to make sure that newlines work like this + `$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]' + + Of course I should still be able to do all this *with* escape sequences + too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'. + + Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. + + And make sure that `0' works too! + + Now, if I use << or >> as my delimiters, then I have to use whitespace. + So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end + up doing what you might expect since the first > will still terminate + the first < seen. + diff --git a/contrib/perl5/t/pod/testcmp.pl b/contrib/perl5/t/pod/testcmp.pl new file mode 100644 index 0000000..5f62171 --- /dev/null +++ b/contrib/perl5/t/pod/testcmp.pl @@ -0,0 +1,91 @@ +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; +use FileHandle; + +@ISA = qw(Exporter); +@EXPORT = qw(&testcmp); +$MYPKG = eval { (caller)[0] }; + +##-------------------------------------------------------------------------- + +=head1 NAME + +testcmp -- compare two files line-by-line + +=head1 SYNOPSIS + + $is_diff = testcmp($file1, $file2); + +or + + $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); + +=head2 DESCRIPTION + +Compare two text files line-by-line and return 0 if they are the +same, 1 if they differ. Each of $file1 and $file2 may be a filenames, +or a filehandles (in which case it must already be open for reading). + +If the first argument is a hashref, then the B<-cmplines> key in the +hash may have a subroutine reference as its corresponding value. +The referenced user-defined subroutine should be a line-comparator +function that takes two pre-chomped text-lines as its arguments +(the first is from $file1 and the second is from $file2). It should +return 0 if it considers the two lines equivalent, and non-zero +otherwise. + +=cut + +##-------------------------------------------------------------------------- + +sub testcmp( $ $ ; $) { + my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); + my ($file1, $file2) = @_; + my ($fh1, $fh2) = ($file1, $file2); + unless (ref $fh1) { + $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; + } + unless (ref $fh2) { + $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; + } + + my $cmplines = $opts{'-cmplines'} || undef; + my ($f1text, $f2text) = ("", ""); + my ($line, $diffs) = (0, 0); + + while ( defined($f1text) and defined($f2text) ) { + defined($f1text = <$fh1>) and chomp($f1text); + defined($f2text = <$fh2>) and chomp($f2text); + ++$line; + last unless ( defined($f1text) and defined($f2text) ); + $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) + : ($f1text ne $f2text); + last if $diffs; + } + close($fh1) unless (ref $file1); + close($fh2) unless (ref $file2); + + $diffs = 1 if (defined($f1text) or defined($f2text)); + if ( defined($f1text) and defined($f2text) ) { + ## these two lines must be different + warn "$file1 and $file2 differ at line $line\n"; + } + elsif (defined($f1text) and (! defined($f1text))) { + ## file1 must be shorter + warn "$file1 is shorter than $file2\n"; + } + elsif (defined $f2text) { + ## file2 must be longer + warn "$file1 is shorter than $file2\n"; + } + return $diffs; +} + +1; diff --git a/contrib/perl5/t/pod/testp2pt.pl b/contrib/perl5/t/pod/testp2pt.pl new file mode 100644 index 0000000..2ff8aa4 --- /dev/null +++ b/contrib/perl5/t/pod/testp2pt.pl @@ -0,0 +1,192 @@ +package TestPodIncPlainText; + +BEGIN { + use File::Basename; + use File::Spec; + use Cwd qw(abs_path); + push @INC, '..'; + my $THISDIR = abs_path(dirname $0); + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); +} + +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; +#use Cwd qw(abs_path); + +use vars qw($MYPKG @EXPORT @ISA); +$MYPKG = eval { (caller)[0] }; +@EXPORT = qw(&testpodplaintext); +BEGIN { + if ( $] >= 5.005_58 ) { + require Pod::Text; + @ISA = qw( Pod::Text ); + } + else { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + } + require VMS::Filespec if $^O eq 'VMS'; +} + +## Hardcode settings for TERMCAP and COLUMNS so we can try to get +## reproducible results between environments +@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); + +sub catfile(@) { File::Spec->catfile(@_); } + +my $INSTDIR = abs_path(dirname $0); +$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; +$INSTDIR =~ s#/$## if $^O eq 'VMS'; +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); +my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), + catfile($INSTDIR, 'scripts'), + catfile($INSTDIR, 'pod'), + catfile($INSTDIR, 't', 'pod') + ); + +## Find the path to the file to =include +sub findinclude { + my $self = shift; + my $incname = shift; + + ## See if its already found w/out any "searching; + return $incname if (-r $incname); + + ## Need to search for it. Look in the following directories ... + ## 1. the directory containing this pod file + my $thispoddir = dirname $self->input_file; + ## 2. the parent directory of the above + my $parentdir = dirname $thispoddir; + my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); + + for (@podincdirs) { + my $incfile = catfile($_, $incname); + return $incfile if (-r $incfile); + } + warn("*** Can't find =include file $incname in @podincdirs\n"); + return ""; +} + +sub command { + my $self = shift; + my ($cmd, $text, $line_num, $pod_para) = @_; + $cmd = '' unless (defined $cmd); + local $_ = $text || ''; + my $out_fh = $self->output_handle; + + ## Defer to the superclass for everything except '=include' + return $self->SUPER::command(@_) unless ($cmd eq "include"); + + ## We have an '=include' command + my $incdebug = 1; ## debugging + my @incargs = split; + if (@incargs == 0) { + warn("*** No filename given for '=include'\n"); + return; + } + my $incfile = $self->findinclude(shift @incargs) or return; + my $incbase = basename $incfile; + print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); + $self->parse_from_file( {-cutting => 1}, $incfile ); + print $out_fh "###### end =include $incbase #####\n" if ($incdebug); +} + +sub begin_input { + $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; +} + +sub podinc2plaintext( $ $ ) { + my ($infile, $outfile) = @_; + local $_; + my $text_parser = $MYPKG->new; + $text_parser->parse_from_file($infile, $outfile); +} + +sub testpodinc2plaintext( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running testpodinc2plaintext for '$testname'...\n"; + ## Compare the output against the expected result + podinc2plaintext($infile, $outfile); + if ( testcmp($outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodplaintext( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " pod2plaintext test ...\n"; + podinc2plaintext($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodinc2plaintext + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/contrib/perl5/t/pod/testpchk.pl b/contrib/perl5/t/pod/testpchk.pl new file mode 100644 index 0000000..8aa10b9 --- /dev/null +++ b/contrib/perl5/t/pod/testpchk.pl @@ -0,0 +1,129 @@ +package TestPodChecker; + +BEGIN { + use File::Basename; + use File::Spec; + push @INC, '..'; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + require "testcmp.pl"; + import TestCompare; + my $PARENTDIR = dirname $THISDIR; + push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); + require VMS::Filespec if $^O eq 'VMS'; +} + +use Pod::Checker; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; + +@ISA = qw(Exporter); +@EXPORT = qw(&testpodchecker); +$MYPKG = eval { (caller)[0] }; + +sub stripname( $ ) { + local $_ = shift; + return /(\w[.\w]*)\s*$/ ? $1 : $_; +} + +sub msgcmp( $ $ ) { + ## filter out platform-dependent aspects of error messages + my ($line1, $line2) = @_; + for ($line1, $line2) { + ## remove filenames from error messages to avoid any + ## filepath naming differences between OS platforms + s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/; + s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/; + } + return ($line1 ne $line2); +} + +sub testpodcheck( @ ) { + my %args = @_; + my $infile = $args{'-In'} || croak "No input file given!"; + my $outfile = $args{'-Out'} || croak "No output file given!"; + my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; + + my $different = ''; + my $testname = basename $cmpfile, '.t', '.xr'; + + unless (-e $cmpfile) { + my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; + warn "$msg\n"; + return $msg; + } + + print "# Running podchecker for '$testname'...\n"; + ## Compare the output against the expected result + if ($^O eq 'VMS') { + for ($infile, $outfile, $cmpfile) { + $_ = VMS::Filespec::unixify($_) unless ref; + } + } + podchecker($infile, $outfile); + if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { + $different = "$outfile is different from $cmpfile"; + } + else { + unlink($outfile); + } + return $different; +} + +sub testpodchecker( @ ) { + my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); + my @testpods = @_; + my ($testname, $testdir) = ("", ""); + my ($podfile, $cmpfile) = ("", ""); + my ($outfile, $errfile) = ("", ""); + my $passes = 0; + my $failed = 0; + local $_; + + print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); + + for $podfile (@testpods) { + ($testname, $_) = fileparse($podfile); + $testdir ||= $_; + $testname =~ s/\.t$//; + $cmpfile = $testdir . $testname . '.xr'; + $outfile = $testdir . $testname . '.OUT'; + + if ($opts{'-xrgen'}) { + if ($opts{'-force'} or ! -e $cmpfile) { + ## Create the comparison file + print "# Creating expected result for \"$testname\"" . + " podchecker test ...\n"; + podchecker($podfile, $cmpfile); + } + else { + print "# File $cmpfile already exists" . + " (use '-force' to regenerate it).\n"; + } + next; + } + + my $failmsg = testpodcheck + -In => $podfile, + -Out => $outfile, + -Cmp => $cmpfile; + if ($failmsg) { + ++$failed; + print "#\tFAILED. ($failmsg)\n"; + print "not ok ", $failed+$passes, "\n"; + } + else { + ++$passes; + unlink($outfile); + print "#\tPASSED.\n"; + print "ok ", $failed+$passes, "\n"; + } + } + return $passes; +} + +1; diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 5b63dfa..6438332 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } -BEGIN {$^W |= 1} # Insist upon warnings +use warnings; use vars qw{ @warnings }; BEGIN { # ...and save 'em for later $SIG{'__WARN__'} = sub { push @warnings, @_ } @@ -14,9 +14,9 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..46\n"; } +BEGIN { $| = 1; print "1..73\n"; } END {print "not ok 1\n" unless $loaded;} -use constant; +use constant 1.01; $loaded = 1; #print "# Version: $constant::VERSION\n"; print "ok 1\n"; @@ -96,11 +96,8 @@ test 23, length(MESS) == 8; use constant TRAILING => '12 cats'; { - my $save_warn; - local $^W; - BEGIN { $save_warn = $^W; $^W = 0 } + no warnings 'numeric'; test 24, TRAILING == 12; - BEGIN { $^W = $save_warn } } test 25, TRAILING eq '12 cats'; @@ -138,7 +135,7 @@ test 37, @warnings && shift @warnings; test 38, @warnings == 0, "unexpected warning"; -test 39, $^W & 1, "Who disabled the warnings?"; +test 39, 1; use constant CSCALAR => \"ok 40\n"; use constant CHASH => { foo => "ok 41\n" }; @@ -151,7 +148,83 @@ print CHASH->{foo}; print CARRAY->[1]; print CPHASH->{foo}; eval q{ CPHASH->{bar} }; -test 44, scalar($@ =~ /^No such array/); +test 44, scalar($@ =~ /^No such pseudo-hash field/); print CCODE->(45); eval q{ CCODE->{foo} }; test 46, scalar($@ =~ /^Constant is not a HASH/); + +# Allow leading underscore +use constant _PRIVATE => 47; +test 47, _PRIVATE == 47; + +# Disallow doubled leading underscore +eval q{ + use constant __DISALLOWED => "Oops"; +}; +test 48, $@ =~ /begins with '__'/; + +# Check on declared() and %declared. This sub should be EXACTLY the +# same as the one quoted in the docs! +sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; +} + +test 49, declared 'PI'; +test 50, $constant::declared{'main::PI'}; + +test 51, !declared 'PIE'; +test 52, !$constant::declared{'main::PIE'}; + +{ + package Other; + use constant IN_OTHER_PACK => 42; + ::test 53, ::declared 'IN_OTHER_PACK'; + ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; + ::test 55, ::declared 'main::PI'; + ::test 56, $constant::declared{'main::PI'}; +} + +test 57, declared 'Other::IN_OTHER_PACK'; +test 58, $constant::declared{'Other::IN_OTHER_PACK'}; + +@warnings = (); +eval q{ + no warnings; + use warnings 'constant'; + use constant 'BEGIN' => 1 ; + use constant 'INIT' => 1 ; + use constant 'CHECK' => 1 ; + use constant 'END' => 1 ; + use constant 'DESTROY' => 1 ; + use constant 'AUTOLOAD' => 1 ; + use constant 'STDIN' => 1 ; + use constant 'STDOUT' => 1 ; + use constant 'STDERR' => 1 ; + use constant 'ARGV' => 1 ; + use constant 'ARGVOUT' => 1 ; + use constant 'ENV' => 1 ; + use constant 'INC' => 1 ; + use constant 'SIG' => 1 ; +}; + +test 59, @warnings == 14 ; +test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; +test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; +test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; +test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; +test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; +test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; +test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; +test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; +test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; +test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; +test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; +test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; +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 = (); diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t new file mode 100755 index 0000000..15cd6b5 --- /dev/null +++ b/contrib/perl5/t/pragma/diagnostics.t @@ -0,0 +1,38 @@ +#!./perl + +BEGIN { + chdir '..' if -d '../pod'; + unshift @INC, './lib' if -d './lib'; +} + + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) +use strict; +use warnings; + +use vars qw($Test_Num $Total_tests); + +my $loaded; +BEGIN { $| = 1; $Test_Num = 1 } +END {print "not ok $Test_Num\n" unless $loaded;} +print "1..$Total_tests\n"; +BEGIN { require diagnostics; } # Don't want diagnostics' noise yet. +$loaded = 1; +ok($loaded, 'compile'); +######################### End of black magic. + +sub ok { + my($test, $name) = shift; + print "not " unless $test; + print "ok $Test_Num"; + print " - $name" if defined $name; + print "\n"; + $Test_Num++; +} + + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 1 } diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 7e3df8c..414ceff 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; + unshift @INC, '.'; require Config; import Config; if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { print "1..0\n"; @@ -12,6 +13,16 @@ BEGIN { use strict; +my $debug = 1; + +sub debug { + print @_ if $debug; +} + +sub debugf { + printf @_ if $debug; +} + my $have_setlocale = 0; eval { require POSIX; @@ -23,17 +34,11 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -# 103 (the last test) may fail but that is okay. -# (It indicates something broken in the environment, not Perl) -# Therefore .. only until 102, not 103. -print "1..", ($have_setlocale ? 102 : 98), "\n"; +print "1..", ($have_setlocale ? 116 : 98), "\n"; -use vars qw($a - $English $German $French $Spanish - @C @English @German @French @Spanish - $Locale @Locale %iLocale %UPPER %lower @Neoalpha); +use vars qw(&LC_ALL); -$a = 'abc %'; +my $a = 'abc %'; sub ok { my ($n, $result) = @_; @@ -47,7 +52,7 @@ sub ok { # even the default locale will taint under 'use locale'. sub is_tainted { # hello, camel two. - local $^W; # no warnings 'undef' + no warnings 'uninitialized' ; my $dummy; not eval { $dummy = join("", @_), kill 0; 1 } } @@ -73,9 +78,9 @@ check_taint 7, "\L$a"; check_taint 8, lcfirst($a); check_taint 9, "\l$a"; -check_taint 10, sprintf('%e', 123.456); -check_taint 11, sprintf('%f', 123.456); -check_taint 12, sprintf('%g', 123.456); +check_taint_not 10, sprintf('%e', 123.456); +check_taint_not 11, sprintf('%f', 123.456); +check_taint_not 12, sprintf('%g', 123.456); check_taint_not 13, sprintf('%d', 123.456); check_taint_not 14, sprintf('%x', 123.456); @@ -219,269 +224,511 @@ check_taint_not 98, $a; # I think we've seen quite enough of taint. # Let us do some *real* locale work now, -# unless setlocale() is missing (i.e. minitest). +# unless setlocale() is missing (i.e. minitest). exit unless $have_setlocale; -sub getalnum { +# Find locales. + +debug "# Scanning for locales...\n"; + +# Note that it's okay that some languages have their native names +# capitalized here even though that's not "right". They are lowercased +# anyway later during the scanning process (and besides, some clueless +# vendor might have them capitalized errorneously anyway). + +my $locales = <<EOF; +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 +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 +Esperanto:eo:eo:3 +Eesti Estonian:et:ee:4 6 13 +Suomi Finnish:fi:fi:1 15 +Flamish::fl:1 15 +Deutsch German:de:at be ch de lu:1 15 +Euskaraz Basque:eu:es fr:1 15 +Galego Galician:gl:es:1 15 +Ellada Greek:el:gr:7 g8 +Frysk:fy:nl:1 15 +Greenlandic:kl:gl:4 6 +Hebrew:iw:il:8 hebrew8 +Hungarian:hu:hu:2 +Indonesian:in:id:1 15 +Gaeilge Irish:ga:IE:1 14 15 +Italiano Italian:it:ch it:1 15 +Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis +Korean:ko:kr: +Latine Latin:la:va:1 15 +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 +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 +Serbski Serbian:sr:yu:5 +Slovak:sk:sk:2 +Slovene Slovenian:sl:si:2 +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 +EOF + +if ($^O eq 'os390') { + $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; + $locales =~ s/Thai:th:th:11 tis620\n//; +} + +sub in_utf8 () { $^H & 0x08 } + +if (in_utf8) { + require "pragma/locale/utf8"; +} else { + require "pragma/locale/latin1"; +} + +my @Locale; +my $Locale; +my @Alnum_; + +sub getalnum_ { sort grep /\w/, map { chr } 0..255 } -sub locatelocale ($$@) { - my ($lcall, $alnum, @try) = @_; +sub trylocale { + my $locale = shift; + if (setlocale(LC_ALL, $locale)) { + push @Locale, $locale; + } +} - undef $$lcall; +sub decode_encodings { + my @enc; - for (@try) { - local $^W = 0; # suppress "Subroutine LC_ALL redefined" - if (setlocale(&LC_ALL, $_)) { - $$lcall = $_; - @$alnum = &getalnum; - last; + foreach (split(/ /, shift)) { + if (/^(\d+)$/) { + push @enc, "ISO8859-$1"; + push @enc, "iso8859$1"; # HP + if ($1 eq '1') { + push @enc, "roman8"; # HP + } + } else { + push @enc, $_; } } + if ($^O eq 'os390') { + push @enc, qw(IBM-037 IBM-819 IBM-1047); + } - @$alnum = () unless (defined $$lcall); + return @enc; } -# Find some default locale - -locatelocale(\$Locale, \@Locale, qw(C POSIX)); - -# Find some English locale - -locatelocale(\$English, \@English, - qw(en_US.ISO8859-1 en_GB.ISO8859-1 - en en_US en_UK en_IE en_CA en_AU en_NZ - english english.iso88591 - american american.iso88591 - british british.iso88591 - )); - -# Find some German locale - -locatelocale(\$German, \@German, - qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 - de de_DE de_AT de_CH - german german.iso88591)); - -# Find some French locale - -locatelocale(\$French, \@French, - qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 - fr fr_FR fr_BE fr_CA fr_CH - french french.iso88591)); - -# Find some Spanish locale - -locatelocale(\$Spanish, \@Spanish, - qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 - es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 - es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 - es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 - es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 - es es_AR es_BO es_CL - es_CO es_CR es_EC - es_ES es_GT es_MX - es_NI es_PA es_PE - es_PY es_SV es_UY es_VE - spanish spanish.iso88591)); - -# Select the largest of the alpha(num)bets. - -($Locale, @Locale) = ($English, @English) - if (@English > @Locale); -($Locale, @Locale) = ($German, @German) - if (@German > @Locale); -($Locale, @Locale) = ($French, @French) - if (@French > @Locale); -($Locale, @Locale) = ($Spanish, @Spanish) - if (@Spanish > @Locale); - -{ - local $^W = 0; - setlocale(&LC_ALL, $Locale); +trylocale("C"); +trylocale("POSIX"); +foreach (0..15) { + trylocale("ISO8859-$_"); + trylocale("iso8859$_"); + trylocale("iso8859-$_"); + trylocale("iso_8859_$_"); + trylocale("isolatin$_"); + trylocale("isolatin-$_"); + 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"); + } + } + 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"); + } + } + } } -# Sort it now that LC_ALL has been set. +setlocale(LC_ALL, "C"); @Locale = sort @Locale; -print "# Locale = $Locale\n"; -print "# Alnum_ = @Locale\n"; +debug "# Locales = @Locale\n"; + +my %Problem; +my %Okay; +my %Testing; +my @Neoalpha; +my %Neoalpha; + +sub tryneoalpha { + my ($Locale, $i, $test) = @_; + debug "# testing $i with locale '$Locale'\n" + unless $Testing{$i}{$Locale}++; + unless ($test) { + $Problem{$i}{$Locale} = 1; + debug "# failed $i with locale '$Locale'\n"; + } else { + push @{$Okay{$i}}, $Locale; + } +} -{ - my $i = 0; +foreach $Locale (@Locale) { + debug "# Locale = $Locale\n"; + @Alnum_ = getalnum_(); + debug "# \\w = @Alnum_\n"; - for (@Locale) { - $iLocale{$_} = $i++; + unless (setlocale(LC_ALL, $Locale)) { + foreach (99..103) { + $Problem{$_}{$Locale} = -1; + } + next; + } + + # Sieve the uppercase and the lowercase. + + my %UPPER = (); + my %lower = (); + my %BoThCaSe = (); + for (@Alnum_) { + if (/[^\d_]/) { # skip digits and the _ + if (uc($_) eq $_) { + $UPPER{$_} = $_; + } + if (lc($_) eq $_) { + $lower{$_} = $_; + } + } + } + foreach (keys %UPPER) { + $BoThCaSe{$_}++ if exists $lower{$_}; + } + foreach (keys %lower) { + $BoThCaSe{$_}++ if exists $UPPER{$_}; + } + foreach (keys %BoThCaSe) { + delete $UPPER{$_}; + delete $lower{$_}; } -} -# Sieve the uppercase and the lowercase. + debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; + debug "# lower = ", join(" ", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; -for (@Locale) { - if (/[^\d_]/) { # skip digits and the _ - if (lc eq $_) { - $UPPER{$_} = uc; - } else { - $lower{$_} = lc; + # Find the alphabets that are not alphabets in the default locale. + + { + no locale; + + @Neoalpha = (); + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + $Neoalpha{$_} = $_; } } -} -# Find the alphabets that are not alphabets in the default locale. + @Neoalpha = sort @Neoalpha; + + debug "# Neoalpha = @Neoalpha\n"; + + if (@Neoalpha == 0) { + # If we have no Neoalphas the remaining tests are no-ops. + debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n"; + foreach (99..102) { + push @{$Okay{$_}}, $Locale; + } + } else { -{ - no locale; + # Test \w. - for (keys %UPPER, keys %lower) { - push(@Neoalpha, $_) if (/\W/); + { + my $word = join('', @Neoalpha); + + $word =~ /^(\w+)$/; + + tryneoalpha($Locale, 99, $1 eq $word); + } + + # Cross-check the whole 8-bit character set. + + for (map { chr } 0..255) { + tryneoalpha($Locale, 100, + (/\w/ xor /\W/) || + (/\d/ xor /\D/) || + (/\s/ xor /\S/)); + } + + # Test for read-only scalars' locale vs non-locale comparisons. + + { + no locale; + $a = "qwerty"; + { + use locale; + tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0); + } + } + + { + my ($from, $to, $lesser, $greater, + @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Alnum_)/10); + $to = $from + int(@Alnum_/10); + $to = $#Alnum_ if ($to > $#Alnum_); + $lesser = join('', @Alnum_[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Alnum_ if ($to > $#Alnum_); + $greater = join('', @Alnum_[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + # Exact lt or gt cannot be tested because + # in some locales, say, eacute and E may test equal. + @test = + ( + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser ge $greater)', # 5 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + 'not (($lesser cmp $greater) == -$sign)' # 12 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { + $test{$ti} = eval $ti; + $test ||= $test{$ti} + } + tryneoalpha($Locale, 102, $test == 0); + if ($test) { + debug "# lesser = '$lesser'\n"; + debug "# greater = '$greater'\n"; + debug "# lesser cmp greater = ", + $lesser cmp $greater, "\n"; + debug "# greater cmp lesser = ", + $greater cmp $lesser, "\n"; + debug "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + debugf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + debugf("(%s == %4d)", $1, eval $1); + } + debug "\n#"; + } + + last; + } + } + } } -} -@Neoalpha = sort @Neoalpha; + use locale; -# Test \w. + my ($x, $y) = (1.23, 1.23); -{ - my $word = join('', @Neoalpha); + my $a = "$x"; + printf ''; # printf used to reset locale to "C" + my $b = "$y"; - $word =~ /^(\w*)$/; + debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; - print 'not ' if ($1 ne $word); -} -print "ok 99\n"; + tryneoalpha($Locale, 103, $a eq $b); -# Find places where the collation order differs from the default locale. + my $c = "$x"; + my $z = sprintf ''; # sprintf used to reset locale to "C" + my $d = "$y"; -print "# testing 100\n"; -{ - my (@k, $i, $j, @d); + debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; + + tryneoalpha($Locale, 104, $c eq $d); { - no locale; + use warnings; + my $w = 0; + local $SIG{__WARN__} = sub { $w++ }; + + # the == (among other ops) used to warn for locales + # that had something else than "." as the radix character + + tryneoalpha($Locale, 105, $c == 1.23); + + tryneoalpha($Locale, 106, $c == $x); + + tryneoalpha($Locale, 107, $c == $d); + + { + no locale; + + my $e = "$x"; + + debug "# 108..110: e = $e, Locale = $Locale\n"; + + tryneoalpha($Locale, 108, $e == 1.23); + + tryneoalpha($Locale, 109, $e == $x); + + tryneoalpha($Locale, 110, $e == $c); + } + + tryneoalpha($Locale, 111, $w == 0); + + my $f = "1.23"; - @k = sort (keys %UPPER, keys %lower); + debug "# 112..114: f = $f, locale = $Locale\n"; + + tryneoalpha($Locale, 112, $f == 1.23); + + tryneoalpha($Locale, 113, $f == $x); + + tryneoalpha($Locale, 114, $f == $c); } - for ($i = 0; $i < @k; $i++) { - for ($j = $i + 1; $j < @k; $j++) { - if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { - push(@d, [$k[$j], $k[$i]]); - } + debug "# testing 115 with locale '$Locale'\n"; + { + use locale; + + sub lcA { + my $lc0 = lc $_[0]; + my $lc1 = lc $_[1]; + return $lc0 cmp $lc1; } + + sub lcB { + return lc($_[0]) cmp lc($_[1]); + } + + my $x = "ab"; + my $y = "aa"; + my $z = "AB"; + + tryneoalpha($Locale, 115, + lcA($x, $y) == 1 && lcB($x, $y) == 1 || + lcA($x, $z) == 0 && lcB($x, $z) == 0); } - # Cross-check those places. + debug "# testing 116 with locale '$Locale'\n"; + { + use locale; - for (@d) { - ($i, $j) = @$_; - if ($i gt $j) { - print "# failed 100 at:\n"; - print "# i = $i, j = $j, i ", - $i le $j ? 'le' : 'gt', " j\n"; - print 'not '; - last; + my @f = (); + foreach my $x (keys %UPPER) { + my $y = lc $x; + next unless uc $y eq $x; + push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } + foreach my $x (keys %lower) { + my $y = uc $x; + next unless lc $y eq $x; + 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; } } -print "ok 100\n"; - -# Cross-check whole character set. - -print "# testing 101\n"; -for (map { chr } 0..255) { - if (/\w/ and /\W/) { print 'not '; last } - if (/\d/ and /\D/) { print 'not '; last } - if (/\s/ and /\S/) { print 'not '; last } - if (/\w/ and /\D/ and not /_/ and - not (exists $UPPER{$_} or exists $lower{$_})) { - print "# failed 101 at:\n"; - print "# ", ord($_), " '$_'\n"; - print 'not '; - last; + +# Recount the errors. + +foreach (99..116) { + if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { + if ($_ == 102) { + print "# The failure of test 102 is not necessarily fatal.\n"; + print "# It usually indicates a problem in the enviroment,\n"; + print "# not in Perl itself.\n"; + } + print "not "; } + print "ok $_\n"; } -print "ok 101\n"; - -# Test for read-onlys. -print "# testing 102\n"; -{ - no locale; - $a = "qwerty"; - { - use locale; - print "not " if $a cmp "qwerty"; +# Give final advice. + +my $didwarn = 0; + +foreach (99..116) { + if ($Problem{$_}) { + my @f = sort keys %{ $Problem{$_} }; + my $f = join(" ", @f); + $f =~ s/(.{50,60}) /$1\n#\t/g; + print + "#\n", + "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n", + "#\t", $f, "\n#\n", + "# on your system may have errors because the locale test $_\n", + "# failed in ", (@f == 1 ? "that locale" : "those locales"), + ".\n"; + print <<EOW; +# +# If your users are not using these locales you are safe for the moment, +# but please report this failure first to perlbug\@perl.com using the +# perlbug script (as described in the INSTALL file) so that the exact +# details of the failures can be sorted out first and then your operating +# system supplier can be alerted about these anomalies. +# +EOW + $didwarn = 1; } } -print "ok 102\n"; - -# This test must be the last one because its failure is not fatal. -# The @Locale should be internally consistent. -# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> -# for inventing a way to test for ordering consistency -# without requiring any particular order. -# <jhi@iki.fi> - -print "# testing 103\n"; -{ - my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); - - for (0..9) { - # Select a slice. - $from = int(($_*@Locale)/10); - $to = $from + int(@Locale/10); - $to = $#Locale if ($to > $#Locale); - $lesser = join('', @Locale[$from..$to]); - # Select a slice one character on. - $from++; $to++; - $to = $#Locale if ($to > $#Locale); - $greater = join('', @Locale[$from..$to]); - ($yes, $no, $sign) = ($lesser lt $greater - ? (" ", "not ", 1) - : ("not ", " ", -1)); - # all these tests should FAIL (return 0). - @test = - ( - $no.' ($lesser lt $greater)', # 0 - $no.' ($lesser le $greater)', # 1 - 'not ($lesser ne $greater)', # 2 - ' ($lesser eq $greater)', # 3 - $yes.' ($lesser ge $greater)', # 4 - $yes.' ($lesser gt $greater)', # 5 - $yes.' ($greater lt $lesser )', # 6 - $yes.' ($greater le $lesser )', # 7 - 'not ($greater ne $lesser )', # 8 - ' ($greater eq $lesser )', # 9 - $no.' ($greater ge $lesser )', # 10 - $no.' ($greater gt $lesser )', # 11 - 'not (($lesser cmp $greater) == -$sign)' # 12 - ); - @test{@test} = 0 x @test; - $test = 0; - for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } - if ($test) { - print "# failed 103 at:\n"; - print "# lesser = '$lesser'\n"; - print "# greater = '$greater'\n"; - print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; - print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; - print "# (greater) from = $from, to = $to\n"; - for my $ti (@test) { - printf("# %-40s %-4s", $ti, - $test{$ti} ? 'FAIL' : 'ok'); - if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { - printf("(%s == %4d)", $1, eval $1); - } - print "\n"; - } - warn "The locale definition on your system may have errors.\n"; - last; +# Tell which locales ere okay. + +if ($didwarn) { + my @s; + + foreach my $l (@Locale) { + my $p = 0; + foreach my $t (102..102) { + $p++ if $Problem{$t}{$l}; } + push @s, $l if $p == 0; } + + my $s = join(" ", @s); + $s =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $s, "\n#\n", + "# tested okay.\n#\n", } # eof diff --git a/contrib/perl5/t/pragma/locale/latin1 b/contrib/perl5/t/pragma/locale/latin1 new file mode 100644 index 0000000..f40f732 --- /dev/null +++ b/contrib/perl5/t/pragma/locale/latin1 @@ -0,0 +1,10 @@ +$locales .= <<EOF; +Catal Catalan:ca:es:1 15 +Franais French:fr:be ca ch fr lu:1 15 +Gidhlig Gaelic:gd:gb uk:1 14 15 +Froyskt Faroese:fo:fo:1 15 +slensku Icelandic:is:is:1 15 +Smi Lappish:::4 6 13 +Portugus Portuguese:po:po br:1 15 +Espanl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 +EOF diff --git a/contrib/perl5/t/pragma/locale/utf8 b/contrib/perl5/t/pragma/locale/utf8 new file mode 100644 index 0000000..fbbe94f --- /dev/null +++ b/contrib/perl5/t/pragma/locale/utf8 @@ -0,0 +1,10 @@ +$locales .= <<EOF; +Català Catalan:ca:es:1 15 +Français French:fr:be ca ch fr lu:1 15 +Gáidhlig Gaelic:gd:gb uk:1 14 15 +Føroyskt Faroese:fo:fo:1 15 +Íslensku Icelandic:is:is:1 15 +Sámi Lappish:::4 6 13 +Português Portuguese:po:po br:1 15 +Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 +EOF diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index 0682266..f9a9c59 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } package Oscalar; @@ -706,5 +706,227 @@ test($c, "bareword"); # 135 my @sorted2 = map $$_, @sorted1; test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; } +{ + package iterator; + use overload '<>' => \&iter; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } +} + +# XXX iterator overload not intended to work with CORE::GLOBAL? +if (defined &CORE::GLOBAL::glob) { + test '1', '1'; # 175 + test '1', '1'; # 176 + test '1', '1'; # 177 +} +else { + my $iter = iterator->new(5); + my $acc = ''; + my $out; + $acc .= " $out" while $out = <${iter}>; + test $acc, ' 5 4 3 2 1 0'; # 175 + $iter = iterator->new(5); + test scalar <${iter}>, '5'; # 176 + $acc = ''; + $acc .= " $out" while $out = <$iter>; + test $acc, ' 4 3 2 1 0'; # 177 +} +{ + package deref; + use overload '%{}' => \&hderef, '&{}' => \&cderef, + '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub deref { + my ($self, $key) = (shift, shift); + my $class = ref $self; + bless $self, 'deref::dummy'; # Disable overloading of %{} + my $out = $self->{$key}; + bless $self, $class; # Restore overloading + $out; + } + sub hderef {shift->deref('h')} + sub aderef {shift->deref('a')} + sub cderef {shift->deref('c')} + sub gderef {shift->deref('g')} + sub sderef {shift->deref('s')} +} +{ + my $deref = bless { h => { foo => 5 , fake => 23 }, + c => sub {return shift() + 34}, + 's' => \123, + a => [11..13], + g => \*srt, + }, 'deref'; + # Hash: + my @cont = sort %$deref; + if ("\t" eq "\011") { # ascii + test "@cont", '23 5 fake foo'; # 178 + } + else { # ebcdic alpha-numeric sort order + test "@cont", 'fake foo 23 5'; # 178 + } + my @keys = sort keys %$deref; + test "@keys", 'fake foo'; # 179 + my @val = sort values %$deref; + test "@val", '23 5'; # 180 + test $deref->{foo}, 5; # 181 + test defined $deref->{bar}, ''; # 182 + my $key; + @keys = (); + push @keys, $key while $key = each %$deref; + @keys = sort @keys; + test "@keys", 'fake foo'; # 183 + test exists $deref->{bar}, ''; # 184 + test exists $deref->{foo}, 1; # 185 + # Code: + test $deref->(5), 39; # 186 + test &$deref(6), 40; # 187 + sub xxx_goto { goto &$deref } + test xxx_goto(7), 41; # 188 + my $srt = bless { c => sub {$b <=> $a} + }, 'deref'; + *srt = \&$srt; + my @sorted = sort srt 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 189 + # Scalar + test $$deref, 123; # 190 + # Code + @sorted = sort $srt 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 191 + # Array + test "@$deref", '11 12 13'; # 192 + test $#$deref, '2'; # 193 + my $l = @$deref; + test $l, 3; # 194 + test $deref->[2], '13'; # 195 + $l = pop @$deref; + test $l, 13; # 196 + $l = 1; + test $deref->[$l], '12'; # 197 + # Repeated dereference + my $double = bless { h => $deref, + }, 'deref'; + test $double->{foo}, 5; # 198 +} + +{ + package two_refs; + use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; + sub new { + my $p = shift; + bless \ [@_], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key] = shift; + } + sub FETCH { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key]; + } +} + +my $bar = new two_refs 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 199 +$bar->{three} = 13; +test $bar->[3], 13; # 200 + +{ + package two_refs_o; + @ISA = ('two_refs'); +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 201 +$bar->{three} = 13; +test $bar->[3], 13; # 202 + +{ + package two_refs1; + use overload '%{}' => sub { ${shift()}->[1] }, + '@{}' => sub { ${shift()}->[0] }; + sub new { + my $p = shift; + my $a = [@_]; + my %h; + tie %h, $p, $a; + bless \ [$a, \%h], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key] = shift; + } + sub FETCH { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key]; + } +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 203 +$bar->{three} = 13; +test $bar->[3], 13; # 204 + +{ + package two_refs1_o; + @ISA = ('two_refs1'); +} + +$bar = new two_refs1_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 205 +$bar->{three} = 13; +test $bar->[3], 13; # 206 + +{ + package B; + use overload bool => sub { ${+shift} }; +} + +my $aaa; +{ my $bbbb = 0; $aaa = bless \$bbbb, B } + +test !$aaa, 1; + +unless ($aaa) { + test 'ok', 'ok'; +} else { + test 'is not', 'ok'; +} + + # Last test is: -sub last {174} +sub last {208} diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs index 7bf1556..10599b0 100644 --- a/contrib/perl5/t/pragma/strict-refs +++ b/contrib/perl5/t/pragma/strict-refs @@ -196,6 +196,7 @@ ${"Fred"} ; require "./abc"; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +Compilation failed in require at - line 2. ######## --FILE-- abc.pm @@ -207,6 +208,7 @@ my $a = ${"Fred"} ; use abc; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## diff --git a/contrib/perl5/t/pragma/strict-subs b/contrib/perl5/t/pragma/strict-subs index 61ec286..ed4fe7a 100644 --- a/contrib/perl5/t/pragma/strict-subs +++ b/contrib/perl5/t/pragma/strict-subs @@ -33,6 +33,24 @@ Execution of - aborted due to compilation errors. ######## # strict subs - error +use strict 'subs' ; +my @a = (A..Z); +EXPECT +Bareword "Z" not allowed while "strict subs" in use at - line 4. +Bareword "A" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict 'subs' ; +my $a = (B..Y); +EXPECT +Bareword "Y" not allowed while "strict subs" in use at - line 4. +Bareword "B" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error use strict ; Fred ; EXPECT @@ -277,3 +295,25 @@ my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 8. Execution of - aborted due to compilation errors. +######## + +# see if Foo->Bar(...) etc work under strictures +use strict; +package Foo; sub Bar { print "@_\n" } +Foo->Bar('a',1); +Bar Foo ('b',2); +Foo->Bar(qw/c 3/); +Bar Foo (qw/d 4/); +Foo::->Bar('A',1); +Bar Foo:: ('B',2); +Foo::->Bar(qw/C 3/); +Bar Foo:: (qw/D 4/); +EXPECT +Foo a 1 +Foo b 2 +Foo c 3 +Foo d 4 +Foo A 1 +Foo B 2 +Foo C 3 +Foo D 4 diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars index 42107fa..ae09742 100644 --- a/contrib/perl5/t/pragma/strict-vars +++ b/contrib/perl5/t/pragma/strict-vars @@ -27,6 +27,15 @@ EXPECT # strict vars - no error use strict 'vars' ; use vars qw( $freddy) ; +BEGIN { *freddy = \$joe::shmoe; } +$freddy = 2 ; +EXPECT + +######## + +# strict vars - no error +use strict 'vars' ; +use vars qw( $freddy) ; local $abc::joe ; my $fred ; my $b = \$fred ; @@ -132,6 +141,40 @@ Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## +--FILE-- abc.pm +package Burp; +use strict; +$a = 1;$f = 1;$k = 1; # just to get beyond the limit... +$b = 1;$g = 1;$l = 1; +$c = 1;$h = 1;$m = 1; +$d = 1;$i = 1;$n = 1; +$e = 1;$j = 1;$o = 1; +$p = 0b12; +--FILE-- +# known scalar leak +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } +use abc; +EXPECT +Global symbol "$f" requires explicit package name at abc.pm line 3. +Global symbol "$k" requires explicit package name at abc.pm line 3. +Global symbol "$g" requires explicit package name at abc.pm line 4. +Global symbol "$l" requires explicit package name at abc.pm line 4. +Global symbol "$c" requires explicit package name at abc.pm line 5. +Global symbol "$h" requires explicit package name at abc.pm line 5. +Global symbol "$m" requires explicit package name at abc.pm line 5. +Global symbol "$d" requires explicit package name at abc.pm line 6. +Global symbol "$i" requires explicit package name at abc.pm line 6. +Global symbol "$n" requires explicit package name at abc.pm line 6. +Global symbol "$e" requires explicit package name at abc.pm line 7. +Global symbol "$j" requires explicit package name at abc.pm line 7. +Global symbol "$o" requires explicit package name at abc.pm line 7. +Global symbol "$p" requires explicit package name at abc.pm line 8. +Illegal binary digit '2' at abc.pm line 8, at end of line +abc.pm has too many errors. +Compilation failed in require at - line 3. +BEGIN failed--compilation aborted at - line 3. +######## + # Check scope of pragma with eval no strict ; eval { @@ -165,6 +208,7 @@ print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 5. +Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## @@ -221,3 +265,135 @@ $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. +######## + +# Check if multiple evals produce same errors +use strict 'vars'; +my $ret = eval q{ print $x; }; +print $@; +print "ok 1\n" unless defined $ret; +$ret = eval q{ print $x; }; +print $@; +print "ok 2\n" unless defined $ret; +EXPECT +Global symbol "$x" requires explicit package name at (eval 1) line 1. +ok 1 +Global symbol "$x" requires explicit package name at (eval 2) line 1. +ok 2 +######## + +# strict vars with outer our - no error +use strict 'vars' ; +our $freddy; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars with inner our - no error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +EXPECT + +######## + +# strict vars with outer our, inner use - no error +use strict 'vars' ; +our $fred; +sub foo { + $fred; +} +EXPECT + +######## + +# strict vars with nested our - no error +use strict 'vars' ; +our $fred; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT + +######## + +# strict vars with elapsed our - error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT +Variable "$fred" is not imported at - line 8. +Global symbol "$fred" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# nested our with local - no error +$fred = 1; +use strict 'vars'; +{ + local our $fred = 2; + print $fred,"\n"; +} +print our $fred,"\n"; +EXPECT +2 +1 +######## + +# "nailed" our declaration visibility across package boundaries +use strict 'vars'; +our $foo; +$foo = 20; +package Foo; +print $foo, "\n"; +EXPECT +20 +######## + +# multiple our declarations in same scope, different packages, no warning +use strict 'vars'; +use warnings; +our $foo; +${foo} = 10; +package Foo; +our $foo = 20; +print $foo, "\n"; +EXPECT +20 +######## + +# multiple our declarations in same scope, same package, warning +use strict 'vars'; +use warnings; +our $foo; +${foo} = 10; +our $foo; +EXPECT +"our" variable $foo masks earlier declaration in same scope at - line 7. +######## + +# multiple our declarations in same scope, same package, warning +use strict 'vars'; +use warnings; +our $foo; +{ + our $foo; + package Foo; + our $foo; +} +EXPECT +"our" variable $foo redeclared at - line 7. + (Did you mean "local" instead of "our"?) +Name "Foo::foo" used only once: possible typo at - line 9. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t index fc32820..c4d6416 100755 --- a/contrib/perl5/t/pragma/strict.t +++ b/contrib/perl5/t/pragma/strict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -65,11 +65,9 @@ for (@prgs){ open TEST, ">$tmpfile"; print TEST $prog,"\n"; close TEST; - my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : - $Is_MSWin32 ? + my $results = $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t new file mode 100755 index 0000000..e96c329 --- /dev/null +++ b/contrib/perl5/t/pragma/sub_lval.t @@ -0,0 +1,429 @@ +print "1..46\n"; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +sub a : lvalue { my $a = 34; bless \$a } # Return a temporary +sub b : lvalue { shift } + +my $out = a(b()); # Check that temporaries are allowed. +print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. +print "ok 1\n"; + +my @out = grep /main/, a(b()); # Check that temporaries are allowed. +print "# `@out'\nnot " unless @out==1; # Not reached if error. +print "ok 2\n"; + +my $in; + +# Check that we can return localized values from subroutines: + +sub in : lvalue { $in = shift; } +sub neg : lvalue { #(num_str) return num_str + local $_ = shift; + s/^\+/-/; + $_; +} +in(neg("+2")); + + +print "# `$in'\nnot " unless $in eq '-2'; +print "ok 3\n"; + +sub get_lex : lvalue { $in } +sub get_st : lvalue { $blah } +sub id : lvalue { shift } +sub id1 : lvalue { $_[0] } +sub inc : lvalue { ++$_[0] } + +$in = 5; +$blah = 3; + +get_st = 7; + +print "# `$blah' ne 7\nnot " unless $blah eq 7; +print "ok 4\n"; + +get_lex = 7; + +print "# `$in' ne 7\nnot " unless $in eq 7; +print "ok 5\n"; + +++get_st; + +print "# `$blah' ne 8\nnot " unless $blah eq 8; +print "ok 6\n"; + +++get_lex; + +print "# `$in' ne 8\nnot " unless $in eq 8; +print "ok 7\n"; + +id(get_st) = 10; + +print "# `$blah' ne 10\nnot " unless $blah eq 10; +print "ok 8\n"; + +id(get_lex) = 10; + +print "# `$in' ne 10\nnot " unless $in eq 10; +print "ok 9\n"; + +++id(get_st); + +print "# `$blah' ne 11\nnot " unless $blah eq 11; +print "ok 10\n"; + +++id(get_lex); + +print "# `$in' ne 11\nnot " unless $in eq 11; +print "ok 11\n"; + +id1(get_st) = 20; + +print "# `$blah' ne 20\nnot " unless $blah eq 20; +print "ok 12\n"; + +id1(get_lex) = 20; + +print "# `$in' ne 20\nnot " unless $in eq 20; +print "ok 13\n"; + +++id1(get_st); + +print "# `$blah' ne 21\nnot " unless $blah eq 21; +print "ok 14\n"; + +++id1(get_lex); + +print "# `$in' ne 21\nnot " unless $in eq 21; +print "ok 15\n"; + +inc(get_st); + +print "# `$blah' ne 22\nnot " unless $blah eq 22; +print "ok 16\n"; + +inc(get_lex); + +print "# `$in' ne 22\nnot " unless $in eq 22; +print "ok 17\n"; + +inc(id(get_st)); + +print "# `$blah' ne 23\nnot " unless $blah eq 23; +print "ok 18\n"; + +inc(id(get_lex)); + +print "# `$in' ne 23\nnot " unless $in eq 23; +print "ok 19\n"; + +++inc(id1(id(get_st))); + +print "# `$blah' ne 25\nnot " unless $blah eq 25; +print "ok 20\n"; + +++inc(id1(id(get_lex))); + +print "# `$in' ne 25\nnot " unless $in eq 25; +print "ok 21\n"; + +@a = (1) x 3; +@b = (undef) x 2; +$#c = 3; # These slots are not fillable. + +# Explanation: empty slots contain &sv_undef. + +=for disabled constructs + +sub a3 :lvalue {@a} +sub b2 : lvalue {@b} +sub c4: lvalue {@c} + +$_ = ''; + +eval <<'EOE' or $_ = $@; + ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); + 1; +EOE + +#@out = ($x, a3, $y, b2, $z, c4, $t); +#@in = (34 .. 41, (undef) x 4, 46); +#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in"; + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +=cut + +print "ok 22\n"; + +my $var; + +sub a::var : lvalue { $var } + +"a"->var = 45; + +print "# `$var' ne 45\nnot " unless $var eq 45; +print "ok 23\n"; + +my $oo; +$o = bless \$oo, "a"; + +$o->var = 47; + +print "# `$var' ne 47\nnot " unless $var eq 47; +print "ok 24\n"; + +sub o : lvalue { $o } + +o->var = 49; + +print "# `$var' ne 49\nnot " unless $var eq 49; +print "ok 25\n"; + +sub nolv () { $x0, $x1 } # Not lvalue + +$_ = ''; + +eval <<'EOE' or $_ = $@; + nolv = (2,3); + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 26\n"; + +$_ = ''; + +eval <<'EOE' or $_ = $@; + nolv = (2,3) if $_; + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 27\n"; + +$_ = ''; + +eval <<'EOE' or $_ = $@; + &nolv = (2,3) if $_; + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 28\n"; + +$x0 = $x1 = $_ = undef; +$nolv = \&nolv; + +eval <<'EOE' or $_ = $@; + $nolv->() = (2,3) if $_; + 1; +EOE + +print "# '$_', '$x0', '$x1'.\nnot " if defined $_; +print "ok 29\n"; + +$x0 = $x1 = $_ = undef; +$nolv = \&nolv; + +eval <<'EOE' or $_ = $@; + $nolv->() = (2,3); + 1; +EOE + +print "# '$_', '$x0', '$x1'.\nnot " + unless /Can\'t modify non-lvalue subroutine call/; +print "ok 30\n"; + +sub lv0 : lvalue { } # Converted to lv10 in scalar context + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv0 = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 31\n"; + +sub lv10 : lvalue {} + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv0) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " if defined $_; +print "ok 32\n"; + +sub lv1u :lvalue { undef } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1u = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 33\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1u) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "ok 34\n"; + +$x = '1234567'; +sub lv1t : lvalue { index $x, 2 } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1t = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 35\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1t) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 36\n"; + +$xxx = 'xxx'; +sub xxx () { $xxx } # Not lvalue +sub lv1tmp : lvalue { xxx } # is it a TEMP? + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1tmp = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 37\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1tmp) = (2,3); + 1; +EOE + +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? + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1tmpr = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 39\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1tmpr) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 40\n"; + +=for disabled constructs + +sub lva : lvalue {@a} + +$_ = undef; +@a = (); +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "ok 41\n"; + +$_ = undef; +@a = (); +$a[0] = undef; +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 42\n"; + +$_ = undef; +@a = (); +$a[0] = undef; +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 43\n"; + +=cut + +print "ok $_\n" for 41..43; + +sub lv1n : lvalue { $newvar } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1n = (3,4); + 1; +EOE + +print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; +print "ok 44\n"; + +sub lv1nn : lvalue { $nnewvar } + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1nn) = (3,4); + 1; +EOE + +print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; +print "ok 45\n"; + +$a = \&lv1nn; +$a->() = 8; +print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; +print "ok 46\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index 6ebbf78..fe84f5e 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -46,10 +46,10 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : + `./perl $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t new file mode 100755 index 0000000..0e55a67 --- /dev/null +++ b/contrib/perl5/t/pragma/utf8.t @@ -0,0 +1,253 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; + if ( ord("\t") != 9 ) { # skip on ebcdic platforms + print "1..0 # Skip utf8 tests on ebcdic platform.\n"; + exit; + } +} + +print "1..60\n"; + +my $test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + use utf8; + $_ = ">\x{263A}<"; + s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\x{80}-\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\\x{80}-\\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = "alpha,numeric"; + m/([[:alpha:]]+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/([[:^lower:]]+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alphaNUMERICstring"; + m/(\p{Ll}+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/(\p{Lu}+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alpha,numeric"; + m/([\p{IsAlpha}]+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/([^\p{IsLower}]+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alpha123numeric456"; + m/([\p{IsDigit}]+)/; + ok $1, '123'; + $test++; + + $_ = "alpha123numeric456"; + m/([^\p{IsDigit}]+)/; + ok $1, 'alpha'; + $test++; + + $_ = ",123alpha,456numeric"; + m/([\p{IsAlnum}]+)/; + ok $1, '123alpha'; + $test++; +} +{ + use utf8; + + $_ = "\x{263A}>\x{263A}\x{263A}"; + + ok length, 4; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 1; + $test++; + + ok length($`), 1; + $test++; + + ok length($1), 1; + $test++; + + ok length($tmp=$&), 2; + $test++; + + ok length($tmp=$'), 1; + $test++; + + ok length($tmp=$`), 1; + $test++; + + ok length($tmp=$1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; + + ok $', pack("C*", 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342, 0230, 0272); + $test++; + + { + use bytes; + no utf8; + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 5; + $test++; + + ok length($`), 3; + $test++; + + ok length($1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342); + $test++; + + ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342); + $test++; + + } + + + { + no utf8; + $_="\342\230\272>\342\230\272\342\230\272"; + } + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 1; + $test++; + + ok length($`), 1; + $test++; + + ok length($1), 1; + $test++; + + ok length($tmp=$&), 2; + $test++; + + ok length($tmp=$'), 1; + $test++; + + ok length($tmp=$`), 1; + $test++; + + ok length($tmp=$1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; + + ok $', pack("C*", 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342, 0230, 0272); + $test++; + + { + use bytes; + no utf8; + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 5; + $test++; + + ok length($`), 3; + $test++; + + ok length($1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342); + $test++; + + ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342); + $test++; + + } +} diff --git a/contrib/perl5/t/pragma/warn/1global b/contrib/perl5/t/pragma/warn/1global new file mode 100644 index 0000000..0af8022 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/1global @@ -0,0 +1,189 @@ +Check existing $^W functionality + + +__END__ + +# warnable code, warnings disabled +$a =+ 3 ; +EXPECT + +######## +-w +# warnable code, warnings enabled via command line switch +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator at - line 4. +Name "main::a" used only once: possible typo at - line 4. +######## + +# compile-time warnable code, warnings enabled via runtime $^W +# so no warning printed. +$^W = 1 ; +$a =+ 3 ; +EXPECT + +######## + +# warnable code, warnings enabled via runtime $^W +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +# warnings enabled at compile time, disabled at run time +BEGIN { $^W = 1 } +$^W = 0 ; +my $b ; chop $b ; +EXPECT + +######## + +# warnings disabled at compile time, enabled at run time +BEGIN { $^W = 0 } +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +$^W = 0; +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT + +######## + +--FILE-- abcd +$^W = 1; +1 ; +--FILE-- +$^W =0 ; +require "./abcd"; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 3. +######## + +$^W = 1; +eval 'my $b ; chop $b ;' ; +print $@ ; +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 1. +######## + +eval '$^W = 1;' ; +print $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +eval {$^W = 1;} ; +print $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +{ + local ($^W) = 1; +} +my $b ; chop $b ; +EXPECT + +######## + +my $a ; chop $a ; +{ + local ($^W) = 1; + my $b ; chop $b ; +} +my $c ; chop $c ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## +-w +-e undef +EXPECT +Use of uninitialized value in -e at - line 2. +######## + +$^W = 1 + 2 ; +EXPECT + +######## + +$^W = $a ; +EXPECT + +######## + +sub fred {} +$^W = fred() ; +EXPECT + +######## + +sub fred { my $b ; chop $b ;} +{ local $^W = 0 ; + fred() ; +} +EXPECT + +######## + +sub fred { my $b ; chop $b ;} +{ local $^W = 1 ; + fred() ; +} +EXPECT +Use of uninitialized value in scalar chop at - line 2. diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use new file mode 100644 index 0000000..60a60c3 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/2use @@ -0,0 +1,308 @@ +Check lexical warnings functionality + +TODO + check that the warning hierarchy works. + +__END__ + +# check illegal category is caught +use warnings 'this-should-never-be-a-warning-category' ; +EXPECT +unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 +BEGIN failed--compilation aborted at - line 3. +######## + +# Check compile time scope of pragma +use warnings 'deprecated' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check compile time scope of pragma +no warnings; +{ + use warnings 'deprecated' ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check runtime scope of pragma +use warnings 'uninitialized' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings 'uninitialized' ; + my $b ; chop $b ; +} +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings 'uninitialized' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +use warnings 'deprecated' ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 3. +######## + +--FILE-- abc +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'deprecated' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1; +--FILE-- +require "./abc"; +1 if $a EQ $b ; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +--FILE-- abc.pm +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings 'uninitialized' ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval { + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval { + no warnings ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings 'deprecated' ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval { + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 5. +Use of EQ is deprecated at - line 7. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval { + no warnings ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval ' + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; +]; print STDERR $@; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval ' + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval ' + no warnings ; + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval ' + 1 if $a EQ $b ; +'; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; +]; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval ' + 1 if $a EQ $b ; +'; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval ' + no warnings ; + 1 if $a EQ $b ; +'; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check the additive nature of the pragma +1 if $a EQ $b ; +my $a ; chop $a ; +use warnings 'deprecated' ; +1 if $a EQ $b ; +my $b ; chop $b ; +use warnings 'uninitialized' ; +my $c ; chop $c ; +no warnings 'deprecated' ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +Use of uninitialized value in scalar chop at - line 9. +Use of uninitialized value in string eq at - line 11. +Use of uninitialized value in string eq at - line 11. diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both new file mode 100644 index 0000000..132b99b --- /dev/null +++ b/contrib/perl5/t/pragma/warn/3both @@ -0,0 +1,197 @@ +Check interaction of $^W and lexical + +__END__ + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +{ local $^W = 0 ; + fred() ; +} + +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +{ $^W = 0 ; + fred() ; +} + +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +{ local $^W = 1 ; + fred() ; +} + +EXPECT + +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +{ $^W = 1 ; + fred() ; +} + +EXPECT + +######## + +# Check interaction of $^W and use warnings +use warnings ; +$^W = 1 ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +$^W = 1 ; +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +$^W = 1 ; +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +no warnings ; +$^W = 1 ; +my $b ; +chop $b ; +EXPECT + +######## +-w +# Check interaction of $^W and use warnings +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## +-w +# Check interaction of $^W and use warnings +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +BEGIN { $^W = 0 } +fred() ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +BEGIN { $^W = 1 } +fred() ; + +EXPECT + +######## + +# Check interaction of $^W and use warnings +use warnings ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +no warnings ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +{ + no warnings ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 10. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 0 } +{ + use warnings ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 7. diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint new file mode 100644 index 0000000..db54f31 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/4lint @@ -0,0 +1,112 @@ +Check lint + +__END__ +-W +# lint: check compile time $^W is zapped +BEGIN { $^W = 0 ;} +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +Use of EQ is deprecated at - line 5. +print() on closed filehandle main::STDIN at - line 6. +######## +-W +# lint: check runtime $^W is zapped +$^W = 0 ; +close STDIN ; print STDIN "abc" ; +EXPECT +print() on closed filehandle main::STDIN at - line 4. +######## +-W +# lint: check runtime $^W is zapped +{ + $^W = 0 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-W +# lint: check "no warnings" is zapped +no warnings ; +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +Use of EQ is deprecated at - line 5. +print() on closed filehandle main::STDIN at - line 6. +######## +-W +# lint: check "no warnings" is zapped +{ + no warnings ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-Ww +# lint: check combination of -w and -W +{ + $^W = 0 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-W +--FILE-- abc.pm +no warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +no warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc +no warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +no warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc.pm +BEGIN {$^W = 0} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 0 ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc +BEGIN {$^W = 0} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 0 ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 3. +Use of uninitialized value in scalar chop at - line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint new file mode 100644 index 0000000..994190a --- /dev/null +++ b/contrib/perl5/t/pragma/warn/5nolint @@ -0,0 +1,96 @@ +Check anti-lint + +__END__ +-X +# nolint: check compile time $^W is zapped +BEGIN { $^W = 1 ;} +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check runtime $^W is zapped +$^W = 1 ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check runtime $^W is zapped +{ + $^W = 1 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-X +# nolint: check "no warnings" is zapped +use warnings ; +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check "no warnings" is zapped +{ + use warnings ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-Xw +# nolint: check combination of -w and -X +{ + $^W = 1 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-X +--FILE-- abc.pm +use warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc +use warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc.pm +BEGIN {$^W = 1} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 1 ; +use abc; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc +BEGIN {$^W = 1} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 1 ; +require "./abc"; +my $a ; chop $a ; +EXPECT diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default new file mode 100644 index 0000000..dd3d182 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/6default @@ -0,0 +1,53 @@ +Check default warnings + +__END__ +# default warnings should be displayed if you don't add anything +# optional shouldn't +my $a = oct "7777777777777777777777777777777777779" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# no warnings should be displayed +no warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +EXPECT +######## +# all warnings should be displayed +use warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '8' ignored at - line 3. +Octal number > 037777777777 non-portable at - line 3. +######## +# check scope +use warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +{ + no warnings ; + my $a = oct "7777777777777777777777777777777777778" ; +} +my $c = oct "7777777777777777777777777777777777778" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '8' ignored at - line 3. +Octal number > 037777777777 non-portable at - line 3. +Integer overflow in octal number at - line 8. +Illegal octal digit '8' ignored at - line 8. +Octal number > 037777777777 non-portable at - line 8. +######## +# all warnings should be displayed +use warnings ; +my $a = oct "0xfffffffffffffffffg" ; +EXPECT +Integer overflow in hexadecimal number at - line 3. +Illegal hexadecimal digit 'g' ignored at - line 3. +Hexadecimal number > 0xffffffff non-portable at - line 3. +######## +# all warnings should be displayed +use warnings ; +my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112"; +EXPECT +Integer overflow in binary number at - line 3. +Illegal binary digit '2' ignored at - line 3. +Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal new file mode 100644 index 0000000..943bb06f --- /dev/null +++ b/contrib/perl5/t/pragma/warn/7fatal @@ -0,0 +1,242 @@ +Check FATAL functionality + +__END__ + +# Check compile time warning +use warnings FATAL => 'deprecated' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check runtime scope of pragma +use warnings FATAL => 'uninitialized' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings FATAL => 'uninitialized' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +--FILE-- abc +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'deprecated' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use warnings FATAL => 'deprecated' ; +1; +--FILE-- +require "./abc"; +1 if $a EQ $b ; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at ./abc line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +--FILE-- abc.pm +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'uninitialized' ; +use abc; +my $a ; chop $a ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at abc.pm line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'uninitialized' ; + my $b ; chop $b ; +}; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at - line 6. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval { + my $b ; chop $b ; +}; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval { + no warnings ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'deprecated' ; + 1 if $a EQ $b ; +}; print STDERR "-- $@" ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval { + 1 if $a EQ $b ; +}; print STDERR "-- $@" ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 5. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval { + no warnings ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'deprecated' ; +}; print STDERR $@ ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +The End. +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings FATAL => 'uninitialized' ; + my $b ; chop $b ; +]; print STDERR "-- $@"; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at (eval 1) line 3. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval ' + my $b ; chop $b ; +'; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval ' + no warnings ; + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings FATAL => 'deprecated' ; + 1 if $a EQ $b ; +]; print STDERR "-- $@"; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of EQ is deprecated at (eval 1) line 3. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval ' + 1 if $a EQ $b ; +'; print STDERR "-- $@"; +print STDERR "The End.\n" ; +EXPECT +-- Use of EQ is deprecated at (eval 1) line 2. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval ' + no warnings ; + 1 if $a EQ $b ; +'; print STDERR "-- $@"; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/8signal b/contrib/perl5/t/pragma/warn/8signal new file mode 100644 index 0000000..d480f19 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/8signal @@ -0,0 +1,18 @@ +Check interaction of __WARN__, __DIE__ & lexical Warnings + +TODO + +__END__ +# 8signal +BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } +BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } +1 if 1 EQ 2 ; +use warnings qw(deprecated) ; +1 if 1 EQ 2 ; +use warnings FATAL => qw(deprecated) ; +1 if 1 EQ 2 ; +print "The End.\n" ; +EXPECT +WARN -- Use of EQ is deprecated at - line 6. +DIE -- Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled new file mode 100755 index 0000000..7facf99 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/9enabled @@ -0,0 +1,819 @@ +Check warnings::enabled & warnings::warn + +__END__ + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("io") ; +1; +--FILE-- +no warnings; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +print "ok1\n" if !warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'syntax' ; +print "ok1\n" if warnings::enabled('io') ; +print "ok2\n" if ! warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'io' ; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +no warnings ; +print "ok1\n" if !warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +use warnings 'syntax' ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("syntax") ; +print "ok3\n" if warnings::enabled("io") ; +1; +--FILE-- +use warnings 'io' ; +require "abc" ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +abc::check() ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("io") ; +1; +--FILE-- def.pm +no warnings; +use abc ; +1; +--FILE-- +use warnings; +use def ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +print "ok3\n" if !warnings::enabled("io") ; +1; +--FILE-- def.pm +use warnings 'syntax' ; +print "ok4\n" if !warnings::enabled('all') ; +print "ok5\n" if warnings::enabled("io") ; +use abc ; +1; +--FILE-- +use warnings 'io' ; +use def ; +EXPECT +ok1 +ok2 +ok3 +ok4 +ok5 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; }; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +eval { use warnings 'io' ; abc::check() ; }; +abc::check() ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { no warnings ; abc::check() } +fred() ; +EXPECT +ok1 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; + print "ok4\n" if ! warnings::enabled("misc") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { use warnings 'io' ; abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +######## + +# check warnings::warn +use warnings ; +eval { warnings::warn() } ; +print $@ ; +eval { warnings::warn("fred", "joe") } ; +print $@ ; +EXPECT +Usage: warnings::warn([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 + require 0 called at - line 6 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings "io" ; +use abc; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("misc", "hello") } +1; +--FILE-- +use warnings "io" ; +use abc; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings qw( FATAL deprecated ) ; +use abc; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +hello at - line 3 +[[]] +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings qw( FATAL io ) ; +use abc; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +[[hello at - line 3 +]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if warnings::enabled("io") ; +print "ok2\n" if warnings::enabled("all") ; +1; +--FILE-- +no warnings; +use abc ; +EXPECT +ok1 +ok2 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if !warnings::enabled("io") ; +print "ok2\n" if !warnings::enabled("all") ; +1; +--FILE-- +use warnings; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok\n" if ! warnings::enabled() ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +eval { abc::check() ; }; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if ! warnings::enabled ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { no warnings ; abc::check() } +fred() ; +EXPECT +ok1 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; + print "ok4\n" if ! warnings::enabled("misc") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { use warnings 'io' ; abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings "abc" ; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +abc::check() ; +EXPECT +hello at - line 2 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL deprecated ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +hello at - line 3 +[[]] +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL abc ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +[[hello at - line 3 +]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use warnings 'all'; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; + print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- def.pm +package def ; +use warnings "io" ; +use warnings::register ; +sub check { + print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ; + print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- +use abc ; +use def ; +use warnings 'abc'; +abc::check() ; +def::check() ; +no warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +use warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +no warnings 'abc' ; +no warnings 'def' ; +abc::check() ; +def::check() ; +use warnings; +abc::check() ; +def::check() ; +no warnings 'abc' ; +abc::check() ; +def::check() ; +EXPECT +abc self enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc enabled +def all not enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all not enabled +def self enabled +def abc enabled +def all not enabled +abc self not enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all enabled +def self enabled +def abc enabled +def all enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled diff --git a/contrib/perl5/t/pragma/warn/av b/contrib/perl5/t/pragma/warn/av new file mode 100644 index 0000000..79bd3b76 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/av @@ -0,0 +1,9 @@ + av.c + + Mandatory Warnings ALL TODO + ------------------ + av_reify called on tied array [av_reify] + + Attempt to clear deleted array [av_clear] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio new file mode 100644 index 0000000..bd40972 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/doio @@ -0,0 +1,191 @@ + doio.c + + Can't open bidirectional pipe [Perl_do_open9] + open(F, "| true |"); + + Missing command in piped open [Perl_do_open9] + open(F, "| "); + + Missing command in piped open [Perl_do_open9] + open(F, " |"); + + warn(warn_nl, "open"); [Perl_do_open9] + open(F, "true\ncd") + + Close on unopened file <%s> [Perl_do_close] <<TODO + $a = "fred";close("$a") + + tell() on unopened file [Perl_do_tell] + $a = "fred";$a = tell($a) + + seek() on unopened file [Perl_do_seek] + $a = "fred";$a = seek($a,1,1) + + sysseek() on unopened file [Perl_do_sysseek] + $a = "fred";$a = seek($a,1,1) + + warn(warn_uninit); [Perl_do_print] + print $a ; + + Stat on unopened file <%s> [Perl_my_stat] + close STDIN ; -x STDIN ; + + warn(warn_nl, "stat"); [Perl_my_stat] + stat "ab\ncd" + + warn(warn_nl, "lstat"); [Perl_my_lstat] + lstat "ab\ncd" + + Can't exec \"%s\": %s [Perl_do_aexec5] + + Can't exec \"%s\": %s [Perl_do_exec3] + + Filehandle %s opened only for output [Perl_do_eof] + my $a = eof STDOUT + + Mandatory Warnings ALL TODO + ------------------ + Can't do inplace edit: %s is not a regular file [Perl_nextargv] + edit a directory + + Can't do inplace edit: %s would not be unique [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't remove %s: %s, skipping file [Perl_nextargv] + Can't do inplace edit on %s: %s [Perl_nextargv] + + +__END__ +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(F); +no warnings 'io' ; +open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(G); +EXPECT +Can't open bidirectional pipe at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, "| "); +no warnings 'io' ; +open(G, "| "); +EXPECT +Missing command in piped open at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, " |"); +no warnings 'io' ; +open(G, " |"); +EXPECT +Missing command in piped open at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, "<true\ncd"); +no warnings 'io' ; +open(G, "<true\ncd"); +EXPECT +Unsuccessful open on filename containing newline at - line 3. +######## +# doio.c [Perl_do_close] <<TODO +use warnings 'unopened' ; +close "fred" ; +no warnings 'unopened' ; +close "joe" ; +EXPECT +Close on unopened file <fred> at - line 3. +######## +# doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] +use warnings 'io' ; +close STDIN ; +tell(STDIN); +$a = seek(STDIN,1,1); +$a = sysseek(STDIN,1,1); +-x STDIN ; +no warnings 'io' ; +close STDIN ; +tell(STDIN); +$a = seek(STDIN,1,1); +$a = sysseek(STDIN,1,1); +-x STDIN ; +EXPECT +tell() on unopened file at - line 4. +seek() on unopened file at - line 5. +sysseek() on unopened file at - line 6. +Stat on unopened file <STDIN> at - line 7. +######## +# doio.c [Perl_do_print] +use warnings 'uninitialized' ; +print $a ; +no warnings 'uninitialized' ; +print $b ; +EXPECT +Use of uninitialized value in print at - line 3. +######## +# doio.c [Perl_my_stat Perl_my_lstat] +use warnings 'io' ; +stat "ab\ncd"; +lstat "ab\ncd"; +no warnings 'io' ; +stat "ab\ncd"; +lstat "ab\ncd"; +EXPECT +Unsuccessful stat on filename containing newline at - line 3. +Unsuccessful stat on filename containing newline at - line 4. +######## +# doio.c [Perl_do_aexec5] +use warnings 'io' ; +exec "lskdjfalksdjfdjfkls","" ; +no warnings 'io' ; +exec "lskdjfalksdjfdjfkls","" ; +EXPECT +OPTION regex +Can't exec "lskdjfalksdjfdjfkls": .+ +######## +# doio.c [Perl_do_exec3] +use warnings 'io' ; +exec "lskdjfalksdjfdjfkls", "abc" ; +no warnings 'io' ; +exec "lskdjfalksdjfdjfkls", "abc" ; +EXPECT +OPTION regex +Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ +######## +# doio.c [Perl_nextargv] +$^W = 0 ; +my $filename = "./temp.dir" ; +mkdir $filename, 0777 + or die "Cannot create directory $filename: $!\n" ; +{ + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + no warnings 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + use warnings 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +rmdir $filename ; +EXPECT +Can't do inplace edit: ./temp.dir is not a regular file at - line 9. +Can't do inplace edit: ./temp.dir is not a regular file at - line 21. + +######## +# doio.c [Perl_do_eof] +use warnings 'io' ; +my $a = eof STDOUT ; +no warnings 'io' ; +$a = eof STDOUT ; +EXPECT +Filehandle main::STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/doop b/contrib/perl5/t/pragma/warn/doop new file mode 100644 index 0000000..5803b44 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/doop @@ -0,0 +1,6 @@ +# doop.c +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +######## diff --git a/contrib/perl5/t/pragma/warn/gv b/contrib/perl5/t/pragma/warn/gv new file mode 100644 index 0000000..5ed4eca --- /dev/null +++ b/contrib/perl5/t/pragma/warn/gv @@ -0,0 +1,54 @@ + gv.c AOK + + Can't locate package %s for @%s::ISA + @ISA = qw(Fred); joe() + + Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + fred() ; + + Use of $# is deprecated + Use of $* is deprecated + + $a = ${"#"} ; + $a = ${"*"} ; + + Mandatory Warnings ALL TODO + ------------------ + + Had to create %s unexpectedly [gv_fetchpv] + Attempt to free unreferenced glob pointers [gp_free] + +__END__ +# gv.c +use warnings 'misc' ; +@ISA = qw(Fred); joe() +EXPECT +Can't locate package Fred for @main::ISA at - line 3. +Undefined subroutine &main::joe called at - line 3. +######## +# gv.c +no warnings 'misc' ; +@ISA = qw(Fred); joe() +EXPECT +Undefined subroutine &main::joe called at - line 3. +######## +# gv.c +sub Other::AUTOLOAD { 1 } sub Other::fred {} +@ISA = qw(Other) ; +use warnings 'deprecated' ; +fred() ; +EXPECT +Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. +######## +# gv.c +use warnings 'deprecated' ; +$a = ${"#"}; +$a = ${"*"}; +no warnings 'deprecated' ; +$a = ${"#"}; +$a = ${"*"}; +EXPECT +Use of $# is deprecated at - line 3. +Use of $* is deprecated at - line 4. diff --git a/contrib/perl5/t/pragma/warn/hv b/contrib/perl5/t/pragma/warn/hv new file mode 100644 index 0000000..c9eec02 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/hv @@ -0,0 +1,8 @@ + hv.c + + + Mandatory Warnings ALL TODO + ------------------ + Attempt to free non-existent shared string [unsharepvn] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/malloc b/contrib/perl5/t/pragma/warn/malloc new file mode 100644 index 0000000..2f8b096 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/malloc @@ -0,0 +1,9 @@ + malloc.c + + + Mandatory Warnings ALL TODO + ------------------ + %s free() ignored [Perl_mfree] + %s", "Bad free() ignored [Perl_mfree] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/mg b/contrib/perl5/t/pragma/warn/mg new file mode 100644 index 0000000..a8f9dbc --- /dev/null +++ b/contrib/perl5/t/pragma/warn/mg @@ -0,0 +1,44 @@ + mg.c AOK + + No such signal: SIG%s + $SIG{FRED} = sub {} + + SIG%s handler \"%s\" not defined. + $SIG{"INT"} = "ok3"; kill "INT",$$; + + Mandatory Warnings TODO + ------------------ + Can't break at that line [magic_setdbline] + +__END__ +# mg.c +use warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT +No such signal: SIGFRED at - line 3. +######## +# mg.c +no warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT + +######## +# mg.c +use warnings 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT +SIGINT handler "fred" not defined. +######## +# mg.c +no warnings 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op new file mode 100644 index 0000000..1a79b4a --- /dev/null +++ b/contrib/perl5/t/pragma/warn/op @@ -0,0 +1,861 @@ + op.c AOK + + "my" variable %s masks earlier declaration in same scope + my $x; + my $x ; + + Variable "%s" may be unavailable + sub x { + my $x; + sub y { + $x + } + } + + Variable "%s" will not stay shared + sub x { + my $x; + sub y { + sub { $x } + } + } + + Found = in conditional, should be == + 1 if $a = 1 ; + + Use of implicit split to @_ is deprecated + split ; + + Use of implicit split to @_ is deprecated + $a = split ; + + Useless use of time in void context + Useless use of a variable in void context + Useless use of a constant in void context + time ; + $a ; + "abc" + + Applying %s to %s will act on scalar(%s) + my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; + @a =~ /abc/ ; + @a =~ s/a/b/ ; + @a =~ tr/a/b/ ; + @$b =~ /abc/ ; + @$b =~ s/a/b/ ; + @$b =~ tr/a/b/ ; + %a =~ /abc/ ; + %a =~ s/a/b/ ; + %a =~ tr/a/b/ ; + %$c =~ /abc/ ; + %$c =~ s/a/b/ ; + %$c =~ tr/a/b/ ; + + + Parentheses missing around "my" list at -e line 1. + my $a, $b = (1,2); + + Parentheses missing around "local" list at -e line 1. + local $a, $b = (1,2); + + Bareword found in conditional at -e line 1. + use warnings 'bareword'; my $x = print(ABC || 1); + + Value of %s may be \"0\"; use \"defined\" + $x = 1 if $x = <FH> ; + $x = 1 while $x = <FH> ; + + Subroutine fred redefined at -e line 1. + sub fred{1;} sub fred{1;} + + Constant subroutine %s redefined + sub fred() {1;} sub fred() {1;} + + Format FRED redefined at /tmp/x line 5. + format FRED = + . + format FRED = + . + + Array @%s missing the @ in argument %d of %s() + push fred ; + + Hash %%%s missing the %% in argument %d of %s() + keys joe ; + + Statement unlikely to be reached + (Maybe you meant system() when you said exec()? + exec "true" ; my $a + + defined(@array) is deprecated + (Maybe you should just omit the defined()?) + my @a ; defined @a ; + defined (@a = (1,2,3)) ; + + defined(%hash) is deprecated + (Maybe you should just omit the defined()?) + my %h ; defined %h ; + + /---/ should probably be written as "---" + join(/---/, @foo); + + %s() called too early to check prototype [Perl_peep] + fred() ; sub fred ($$) {} + + + Mandatory Warnings + ------------------ + Prototype mismatch: [cv_ckproto] + sub fred() ; + sub fred($) {} + + %s never introduced [pad_leavemy] TODO + Runaway prototype [newSUB] TODO + oops: oopsAV [oopsAV] TODO + oops: oopsHV [oopsHV] TODO + + +__END__ +# op.c +use warnings 'misc' ; +my $x ; +my $x ; +no warnings 'misc' ; +my $x ; +EXPECT +"my" variable $x masks earlier declaration in same scope at - line 4. +######## +# op.c +use warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT +Variable "$x" will not stay shared at - line 7. +######## +# op.c +no warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c +use warnings 'closure' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT +Variable "$x" may be unavailable at - line 6. +######## +# op.c +no warnings 'closure' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT + +######## +# op.c +use warnings 'syntax' ; +1 if $a = 1 ; +no warnings 'syntax' ; +1 if $a = 1 ; +EXPECT +Found = in conditional, should be == at - line 3. +######## +# op.c +use warnings 'deprecated' ; +split ; +no warnings 'deprecated' ; +split ; +EXPECT +Use of implicit split to @_ is deprecated at - line 3. +######## +# op.c +use warnings 'deprecated' ; +$a = split ; +no warnings 'deprecated' ; +$a = split ; +EXPECT +Use of implicit split to @_ is deprecated at - line 3. +######## +# op.c +use warnings 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT + # OP_GVSV +wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN +ref ; # OP_REF +\@a ; # OP_REFGEN +\$a ; # OP_SREFGEN +defined $a ; # OP_DEFINED +hex $a ; # OP_HEX +oct $a ; # OP_OCT +length $a ; # OP_LENGTH +substr $a,1 ; # OP_SUBSTR +vec $a,1,2 ; # OP_VEC +index $a,1,2 ; # OP_INDEX +rindex $a,1,2 ; # OP_RINDEX +sprintf $a ; # OP_SPRINTF +$a[0] ; # OP_AELEM + # OP_AELEMFAST +@a[0] ; # OP_ASLICE +#values %a ; # OP_VALUES +#keys %a ; # OP_KEYS +$a{0} ; # OP_HELEM +@a{0} ; # OP_HSLICE +unpack "a", "a" ; # OP_UNPACK +pack $a,"" ; # OP_PACK +join "" ; # OP_JOIN +(@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH +sort(1,2) ; # OP_SORT +reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP +(1 ..2) ; # OP_FLOP +caller ; # OP_CALLER +fileno STDIN ; # OP_FILENO +eof STDIN ; # OP_EOF +tell STDIN ; # OP_TELL +readlink 1; # OP_READLINK +time ; # OP_TIME +localtime ; # OP_LOCALTIME +gmtime ; # OP_GMTIME +eval { getgrnam 1 }; # OP_GGRNAM +eval { getgrgid 1 }; # OP_GGRGID +eval { getpwnam 1 }; # OP_GPWNAM +eval { getpwuid 1 }; # OP_GPWUID +EXPECT +Useless use of repeat (x) in void context at - line 3. +Useless use of wantarray in void context at - line 5. +Useless use of reference-type operator in void context at - line 12. +Useless use of reference constructor in void context at - line 13. +Useless use of single ref constructor in void context at - line 14. +Useless use of defined operator in void context at - line 15. +Useless use of hex in void context at - line 16. +Useless use of oct in void context at - line 17. +Useless use of length in void context at - line 18. +Useless use of substr in void context at - line 19. +Useless use of vec in void context at - line 20. +Useless use of index in void context at - line 21. +Useless use of rindex in void context at - line 22. +Useless use of sprintf in void context at - line 23. +Useless use of array element in void context at - line 24. +Useless use of array slice in void context at - line 26. +Useless use of hash element in void context at - line 29. +Useless use of hash slice in void context at - line 30. +Useless use of unpack in void context at - line 31. +Useless use of pack in void context at - line 32. +Useless use of join in void context at - line 33. +Useless use of list slice in void context at - line 34. +Useless use of sort in void context at - line 37. +Useless use of reverse in void context at - line 38. +Useless use of range (or flop) in void context at - line 41. +Useless use of caller in void context at - line 42. +Useless use of fileno in void context at - line 43. +Useless use of eof in void context at - line 44. +Useless use of tell in void context at - line 45. +Useless use of readlink in void context at - line 46. +Useless use of time in void context at - line 47. +Useless use of localtime in void context at - line 48. +Useless use of gmtime in void context at - line 49. +Useless use of getgrnam in void context at - line 50. +Useless use of getgrgid in void context at - line 51. +Useless use of getpwnam in void context at - line 52. +Useless use of getpwuid in void context at - line 53. +######## +# op.c +no warnings 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT + # OP_GVSV +wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN +ref ; # OP_REF +\@a ; # OP_REFGEN +\$a ; # OP_SREFGEN +defined $a ; # OP_DEFINED +hex $a ; # OP_HEX +oct $a ; # OP_OCT +length $a ; # OP_LENGTH +substr $a,1 ; # OP_SUBSTR +vec $a,1,2 ; # OP_VEC +index $a,1,2 ; # OP_INDEX +rindex $a,1,2 ; # OP_RINDEX +sprintf $a ; # OP_SPRINTF +$a[0] ; # OP_AELEM + # OP_AELEMFAST +@a[0] ; # OP_ASLICE +#values %a ; # OP_VALUES +#keys %a ; # OP_KEYS +$a{0} ; # OP_HELEM +@a{0} ; # OP_HSLICE +unpack "a", "a" ; # OP_UNPACK +pack $a,"" ; # OP_PACK +join "" ; # OP_JOIN +(@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH +sort(1,2) ; # OP_SORT +reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP +(1 ..2) ; # OP_FLOP +caller ; # OP_CALLER +fileno STDIN ; # OP_FILENO +eof STDIN ; # OP_EOF +tell STDIN ; # OP_TELL +readlink 1; # OP_READLINK +time ; # OP_TIME +localtime ; # OP_LOCALTIME +gmtime ; # OP_GMTIME +eval { getgrnam 1 }; # OP_GGRNAM +eval { getgrgid 1 }; # OP_GGRGID +eval { getpwnam 1 }; # OP_GPWNAM +eval { getpwuid 1 }; # OP_GPWUID +EXPECT +######## +# op.c +use warnings 'void' ; +for (@{[0]}) { "$_" } # check warning isn't duplicated +no warnings 'void' ; +for (@{[0]}) { "$_" } # check warning isn't duplicated +EXPECT +Useless use of string in void context at - line 3. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_telldir}) { + print <<EOM ; +SKIPPED +# telldir not present +EOM + exit + } +} +telldir 1 ; # OP_TELLDIR +no warnings 'void' ; +telldir 1 ; # OP_TELLDIR +EXPECT +Useless use of telldir in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getppid}) { + print <<EOM ; +SKIPPED +# getppid not present +EOM + exit + } +} +getppid ; # OP_GETPPID +no warnings 'void' ; +getppid ; # OP_GETPPID +EXPECT +Useless use of getppid in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getpgrp}) { + print <<EOM ; +SKIPPED +# getpgrp not present +EOM + exit + } +} +getpgrp ; # OP_GETPGRP +no warnings 'void' ; +getpgrp ; # OP_GETPGRP +EXPECT +Useless use of getpgrp in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_times}) { + print <<EOM ; +SKIPPED +# times not present +EOM + exit + } +} +times ; # OP_TMS +no warnings 'void' ; +times ; # OP_TMS +EXPECT +Useless use of times in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22 + print <<EOM ; +SKIPPED +# getpriority not present +EOM + exit + } +} +getpriority 1,2; # OP_GETPRIORITY +no warnings 'void' ; +getpriority 1,2; # OP_GETPRIORITY +EXPECT +Useless use of getpriority in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getlogin}) { + print <<EOM ; +SKIPPED +# getlogin not present +EOM + exit + } +} +getlogin ; # OP_GETLOGIN +no warnings 'void' ; +getlogin ; # OP_GETLOGIN +EXPECT +Useless use of getlogin in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; BEGIN { +if ( ! $Config{d_socket}) { + print <<EOM ; +SKIPPED +# getsockname not present +# getpeername not present +# gethostbyname not present +# gethostbyaddr not present +# gethostent not present +# getnetbyname not present +# getnetbyaddr not present +# getnetent not present +# getprotobyname not present +# getprotobynumber not present +# getprotoent not present +# getservbyname not present +# getservbyport not present +# getservent not present +EOM + exit +} } +getsockname STDIN ; # OP_GETSOCKNAME +getpeername STDIN ; # OP_GETPEERNAME +gethostbyname 1 ; # OP_GHBYNAME +gethostbyaddr 1,2; # OP_GHBYADDR +gethostent ; # OP_GHOSTENT +getnetbyname 1 ; # OP_GNBYNAME +getnetbyaddr 1,2 ; # OP_GNBYADDR +getnetent ; # OP_GNETENT +getprotobyname 1; # OP_GPBYNAME +getprotobynumber 1; # OP_GPBYNUMBER +getprotoent ; # OP_GPROTOENT +getservbyname 1,2; # OP_GSBYNAME +getservbyport 1,2; # OP_GSBYPORT +getservent ; # OP_GSERVENT + +no warnings 'void' ; +getsockname STDIN ; # OP_GETSOCKNAME +getpeername STDIN ; # OP_GETPEERNAME +gethostbyname 1 ; # OP_GHBYNAME +gethostbyaddr 1,2; # OP_GHBYADDR +gethostent ; # OP_GHOSTENT +getnetbyname 1 ; # OP_GNBYNAME +getnetbyaddr 1,2 ; # OP_GNBYADDR +getnetent ; # OP_GNETENT +getprotobyname 1; # OP_GPBYNAME +getprotobynumber 1; # OP_GPBYNUMBER +getprotoent ; # OP_GPROTOENT +getservbyname 1,2; # OP_GSBYNAME +getservbyport 1,2; # OP_GSBYPORT +getservent ; # OP_GSERVENT +INIT { + # some functions may not be there, so we exit without running + exit; +} +EXPECT +Useless use of getsockname in void context at - line 24. +Useless use of getpeername in void context at - line 25. +Useless use of gethostbyname in void context at - line 26. +Useless use of gethostbyaddr in void context at - line 27. +Useless use of gethostent in void context at - line 28. +Useless use of getnetbyname in void context at - line 29. +Useless use of getnetbyaddr in void context at - line 30. +Useless use of getnetent in void context at - line 31. +Useless use of getprotobyname in void context at - line 32. +Useless use of getprotobynumber in void context at - line 33. +Useless use of getprotoent in void context at - line 34. +Useless use of getservbyname in void context at - line 35. +Useless use of getservbyport in void context at - line 36. +Useless use of getservent in void context at - line 37. +######## +# op.c +use warnings 'void' ; +*a ; # OP_RV2GV +$a ; # OP_RV2SV +@a ; # OP_RV2AV +%a ; # OP_RV2HV +no warnings 'void' ; +*a ; # OP_RV2GV +$a ; # OP_RV2SV +@a ; # OP_RV2AV +%a ; # OP_RV2HV +EXPECT +Useless use of a variable in void context at - line 3. +Useless use of a variable in void context at - line 4. +Useless use of a variable in void context at - line 5. +Useless use of a variable in void context at - line 6. +######## +# op.c +use warnings 'void' ; +"abc"; # OP_CONST +7 ; # OP_CONST +no warnings 'void' ; +"abc"; # OP_CONST +7 ; # OP_CONST +EXPECT +Useless use of a constant in void context at - line 3. +Useless use of a constant in void context at - line 4. +######## +# op.c +BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak +use warnings 'misc' ; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; +@a =~ /abc/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; +@$b =~ /abc/ ; +@$b =~ s/a/b/ ; +@$b =~ tr/a/b/ ; +%a =~ /abc/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; +%$c =~ /abc/ ; +%$c =~ s/a/b/ ; +%$c =~ tr/a/b/ ; +{ +no warnings 'misc' ; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; +@a =~ /abc/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; +@$b =~ /abc/ ; +@$b =~ s/a/b/ ; +@$b =~ tr/a/b/ ; +%a =~ /abc/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; +%$c =~ /abc/ ; +%$c =~ s/a/b/ ; +%$c =~ tr/a/b/ ; +} +EXPECT +Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. +Applying substitution (s///) to @array will act on scalar(@array) at - line 6. +Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" +Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. +Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. +Applying substitution (s///) to @array will act on scalar(@array) at - line 9. +Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10. +Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11. +Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12. +Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13. +Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. +Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. +Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. +BEGIN not safe after errors--compilation aborted at - line 18. +######## +# op.c +use warnings 'syntax' ; +my $a, $b = (1,2); +no warnings 'syntax' ; +my $c, $d = (1,2); +EXPECT +Parentheses missing around "my" list at - line 3. +######## +# op.c +use warnings 'syntax' ; +local $a, $b = (1,2); +no warnings 'syntax' ; +local $c, $d = (1,2); +EXPECT +Parentheses missing around "local" list at - line 3. +######## +# op.c +use warnings 'bareword' ; +print (ABC || 1) ; +no warnings 'bareword' ; +print (ABC || 1) ; +EXPECT +Bareword found in conditional at - line 3. +######## +--FILE-- abc + +--FILE-- +# op.c +use warnings 'misc' ; +open FH, "<abc" ; +$x = 1 if $x = <FH> ; +no warnings 'misc' ; +$x = 1 if $x = <FH> ; +EXPECT +Value of <HANDLE> construct can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +opendir FH, "." ; +$x = 1 if $x = readdir FH ; +no warnings 'misc' ; +$x = 1 if $x = readdir FH ; +closedir FH ; +EXPECT +Value of readdir() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +$x = 1 if $x = <*> ; +no warnings 'misc' ; +$x = 1 if $x = <*> ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'misc' ; +%a = (1,2,3,4) ; +$x = 1 if $x = each %a ; +no warnings 'misc' ; +$x = 1 if $x = each %a ; +EXPECT +Value of each() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +$x = 1 while $x = <*> and 0 ; +no warnings 'misc' ; +$x = 1 while $x = <*> and 0 ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'misc' ; +opendir FH, "." ; +$x = 1 while $x = readdir FH and 0 ; +no warnings 'misc' ; +$x = 1 while $x = readdir FH and 0 ; +closedir FH ; +EXPECT +Value of readdir() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'redefine' ; +sub fred {} +sub fred {} +no warnings 'redefine' ; +sub fred {} +EXPECT +Subroutine fred redefined at - line 4. +######## +# op.c +use warnings 'redefine' ; +sub fred () { 1 } +sub fred () { 1 } +no warnings 'redefine' ; +sub fred () { 1 } +EXPECT +Constant subroutine fred redefined at - line 4. +######## +# op.c +use warnings 'redefine' ; +format FRED = +. +format FRED = +. +no warnings 'redefine' ; +format FRED = +. +EXPECT +Format FRED redefined at - line 5. +######## +# op.c +use warnings 'deprecated' ; +push FRED; +no warnings 'deprecated' ; +push FRED; +EXPECT +Array @FRED missing the @ in argument 1 of push() at - line 3. +######## +# op.c +use warnings 'deprecated' ; +@a = keys FRED ; +no warnings 'deprecated' ; +@a = keys FRED ; +EXPECT +Hash %FRED missing the % in argument 1 of keys() at - line 3. +######## +# op.c +use warnings 'syntax' ; +exec "$^X -e 1" ; +my $a +EXPECT +Statement unlikely to be reached at - line 4. + (Maybe you meant system() when you said exec()?) +######## +# op.c +use warnings 'deprecated' ; +my @a; defined(@a); +EXPECT +defined(@array) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +use warnings 'deprecated' ; +defined(@a = (1,2,3)); +EXPECT +defined(@array) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +use warnings 'deprecated' ; +my %h; defined(%h); +EXPECT +defined(%hash) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +no warnings 'syntax' ; +exec "$^X -e 1" ; +my $a +EXPECT + +######## +# op.c +sub fred(); +sub fred($) {} +EXPECT +Prototype mismatch: sub main::fred () vs ($) at - line 3. +######## +# op.c +$^W = 0 ; +sub fred() ; +sub fred($) {} +{ + no warnings 'prototype' ; + sub Fred() ; + sub Fred($) {} + use warnings 'prototype' ; + sub freD() ; + sub freD($) {} +} +sub FRED() ; +sub FRED($) {} +EXPECT +Prototype mismatch: sub main::fred () vs ($) at - line 4. +Prototype mismatch: sub main::freD () vs ($) at - line 11. +Prototype mismatch: sub main::FRED () vs ($) at - line 14. +######## +# op.c +use warnings 'syntax' ; +join /---/, 'x', 'y', 'z'; +EXPECT +/---/ should probably be written as "---" at - line 3. +######## +# op.c [Perl_peep] +use warnings 'prototype' ; +fred() ; +sub fred ($$) {} +no warnings 'prototype' ; +joe() ; +sub joe ($$) {} +EXPECT +main::fred() called too early to check prototype at - line 3. +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +use warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +use abc; +delete $INC{"abc.pm"}; +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in check +in init +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in end +in end +in end +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +no warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in begin +in mainline +in end +in end diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl new file mode 100644 index 0000000..4580749 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perl @@ -0,0 +1,57 @@ + perl.c AOK + + gv_check(defstash) + Name \"%s::%s\" used only once: possible typo + + Mandatory Warnings All TODO + ------------------ + Recompile perl with -DDEBUGGING to use -D switch [moreswitches] + Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct] + Unbalanced saves: %ld more saves than restores [perl_destruct] + Unbalanced tmps: %ld more allocs than frees [perl_destruct] + Unbalanced context: %ld more PUSHes than POPs [perl_destruct] + Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct] + Scalars leaked: %ld [perl_destruct] + + +__END__ +# perl.c +no warnings 'once' ; +$x = 3 ; +use warnings 'once' ; +$z = 3 ; +EXPECT +Name "main::z" used only once: possible typo at - line 5. +######## +-w +# perl.c +$x = 3 ; +no warnings 'once' ; +$z = 3 +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## +# perl.c +BEGIN { $^W =1 ; } +$x = 3 ; +no warnings 'once' ; +$z = 3 +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## +-W +# perl.c +no warnings 'once' ; +$x = 3 ; +use warnings 'once' ; +$z = 3 ; +EXPECT +Name "main::x" used only once: possible typo at - line 4. +Name "main::z" used only once: possible typo at - line 6. +######## +-X +# perl.c +use warnings 'once' ; +$x = 3 ; +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/perlio b/contrib/perl5/t/pragma/warn/perlio new file mode 100644 index 0000000..18c0dfa --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perlio @@ -0,0 +1,10 @@ + perlio.c + + + Mandatory Warnings ALL TODO + ------------------ + Setting cnt to %d + Setting ptr %p > end+1 %p + Setting cnt to %d, ptr implies %d + +__END__ diff --git a/contrib/perl5/t/pragma/warn/perly b/contrib/perl5/t/pragma/warn/perly new file mode 100644 index 0000000..afc5dcc --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perly @@ -0,0 +1,31 @@ + perly.y AOK + + dep() => deprecate("\"do\" to call subroutines") + Use of "do" to call subroutines is deprecated + + sub fred {} do fred() + sub fred {} do fred(1) + sub fred {} $a = "fred" ; do $a() + sub fred {} $a = "fred" ; do $a(1) + + +__END__ +# perly.y +use warnings 'deprecated' ; +sub fred {} +do fred() ; +do fred(1) ; +$a = "fred" ; +do $a() ; +do $a(1) ; +no warnings 'deprecated' ; +do fred() ; +do fred(1) ; +$a = "fred" ; +do $a() ; +do $a(1) ; +EXPECT +Use of "do" to call subroutines is deprecated at - line 4. +Use of "do" to call subroutines is deprecated at - line 5. +Use of "do" to call subroutines is deprecated at - line 7. +Use of "do" to call subroutines is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/pp b/contrib/perl5/t/pragma/warn/pp new file mode 100644 index 0000000..8f42ba6 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp @@ -0,0 +1,110 @@ + pp.c TODO + + substr outside of string + $a = "ab" ; $b = substr($a, 4,5) ; + + Attempt to use reference as lvalue in substr + $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b + + uninitialized in pp_rv2gv() + my *b = *{ undef()} + + uninitialized in pp_rv2sv() + my $a = undef ; my $b = $$a + + Odd number of elements in hash list + my $a = { 1,2,3 } ; + + Invalid type in unpack: '%c + my $A = pack ("A,A", 1,2) ; + my @A = unpack ("A,A", "22") ; + + Attempt to pack pointer to temporary value + pack("p", "abc") ; + + Explicit blessing to '' (assuming package main) + bless \[], ""; + + Constant subroutine %s undefined <<<TODO + Constant subroutine (anonymous) undefined <<<TODO + +__END__ +# pp.c +use warnings 'substr' ; +$a = "ab" ; +$b = substr($a, 4,5) ; +no warnings 'substr' ; +$a = "ab" ; +$b = substr($a, 4,5) ; +EXPECT +substr outside of string at - line 4. +######## +# pp.c +use warnings 'substr' ; +$a = "ab" ; +$b = \$a ; +substr($b, 1,1) = "ab" ; +no warnings 'substr' ; +substr($b, 1,1) = "ab" ; +EXPECT +Attempt to use reference as lvalue in substr at - line 5. +######## +# pp.c +use warnings 'uninitialized' ; +# TODO +EXPECT + +######## +# pp.c +use warnings 'misc' ; +my $a = { 1,2,3}; +no warnings 'misc' ; +my $b = { 1,2,3}; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp.c +use warnings 'pack' ; +use warnings 'unpack' ; +my @a = unpack ("A,A", "22") ; +my $a = pack ("A,A", 1,2) ; +no warnings 'pack' ; +no warnings 'unpack' ; +my @b = unpack ("A,A", "22") ; +my $b = pack ("A,A", 1,2) ; +EXPECT +Invalid type in unpack: ',' at - line 4. +Invalid type in pack: ',' at - line 5. +######## +# pp.c +use warnings 'uninitialized' ; +my $a = undef ; +my $b = $$a; +no warnings 'uninitialized' ; +my $c = $$a; +EXPECT +Use of uninitialized value in scalar dereference at - line 4. +######## +# pp.c +use warnings 'pack' ; +sub foo { my $a = "a"; return $a . $a++ . $a++ } +my $a = pack("p", &foo) ; +no warnings 'pack' ; +my $b = pack("p", &foo) ; +EXPECT +Attempt to pack pointer to temporary value at - line 4. +######## +# pp.c +use warnings 'misc' ; +bless \[], "" ; +no warnings 'misc' ; +bless \[], "" ; +EXPECT +Explicit blessing to '' (assuming package main) at - line 3. +######## +# pp.c +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +######## diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl new file mode 100644 index 0000000..0deccd3 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_ctl @@ -0,0 +1,217 @@ + pp_ctl.c AOK + + Not enough format arguments + format STDOUT = + @<<< @<<< + $a + . + write; + + + Exiting substitution via %s + $_ = "abc" ; + while ($i ++ == 0) + { + s/ab/last/e ; + } + + Exiting subroutine via %s + sub fred { last } + { fred() } + + Exiting eval via %s + { eval "last" } + + Exiting pseudo-block via %s + @a = (1,2) ; @b = sort { last } @a ; + + Exiting substitution via %s + $_ = "abc" ; + last fred: + while ($i ++ == 0) + { + s/ab/last fred/e ; + } + + + Exiting subroutine via %s + sub fred { last joe } + joe: { fred() } + + Exiting eval via %s + fred: { eval "last fred" } + + Exiting pseudo-block via %s + @a = (1,2) ; fred: @b = sort { last fred } @a ; + + + Deep recursion on subroutine \"%s\" + sub fred + { + fred() if $a++ < 200 + } + + fred() + + (in cleanup) foo bar + package Foo; + DESTROY { die "foo bar" } + { bless [], 'Foo' for 1..10 } + +__END__ +# pp_ctl.c +use warnings 'syntax' ; +format STDOUT = +@<<< @<<< +1 +. +write; +EXPECT +Not enough format arguments at - line 5. +1 +######## +# pp_ctl.c +no warnings 'syntax' ; +format = +@<<< @<<< +1 +. +write ; +EXPECT +1 +######## +# pp_ctl.c +use warnings 'exiting' ; +$_ = "abc" ; + +while ($i ++ == 0) +{ + s/ab/last/e ; +} +no warnings 'exiting' ; +while ($i ++ == 0) +{ + s/ab/last/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'exiting' ; +sub fred { last } +{ fred() } +no warnings 'exiting' ; +sub joe { last } +{ joe() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +{ + eval "use warnings 'exiting' ; last;" +} +print STDERR $@ ; +{ + eval "no warnings 'exiting' ;last;" +} +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'exiting' ; +@a = (1,2) ; +@b = sort { last } @a ; +no warnings 'exiting' ; +@b = sort { last } @a ; +EXPECT +Exiting pseudo-block via last at - line 4. +Can't "last" outside a loop block at - line 4. +######## +# pp_ctl.c +use warnings 'exiting' ; +$_ = "abc" ; +fred: +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +no warnings 'exiting' ; +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'exiting' ; +sub fred { last joe } +joe: { fred() } +no warnings 'exiting' ; +sub Fred { last Joe } +Joe: { Fred() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +joe: +{ eval "use warnings 'exiting' ; last joe;" } +print STDERR $@ ; +Joe: +{ eval "no warnings 'exiting' ; last Joe;" } +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'exiting' ; +@a = (1,2) ; +fred: @b = sort { last fred } @a ; +no warnings 'exiting' ; +Fred: @b = sort { last Fred } @a ; +EXPECT +Exiting pseudo-block via last at - line 4. +Label not found for "last fred" at - line 4. +######## +# pp_ctl.c +use warnings 'recursion' ; +BEGIN { warn "PREFIX\n" ;} +sub fred +{ + fred() if $a++ < 200 +} + +fred() +EXPECT +Deep recursion on subroutine "main::fred" at - line 6. +######## +# pp_ctl.c +no warnings 'recursion' ; +BEGIN { warn "PREFIX\n" ;} +sub fred +{ + fred() if $a++ < 200 +} + +fred() +EXPECT +######## +# pp_ctl.c +use warnings 'misc' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + (in cleanup) A foo bar at - line 4. + (in cleanup) B foo bar at - line 4. +######## +# pp_ctl.c +no warnings 'misc' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot new file mode 100644 index 0000000..2759057 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_hot @@ -0,0 +1,226 @@ + pp_hot.c + + Filehandle %s never opened [pp_print] + $f = $a = "abc" ; print $f $a + + Filehandle %s opened only for input [pp_print] + print STDIN "abc" ; + + Filehandle %s opened only for output [pp_print] + print <STDOUT> ; + + print() on closed filehandle %s [pp_print] + close STDIN ; print STDIN "abc" ; + + uninitialized [pp_rv2av] + my $a = undef ; my @b = @$a + + uninitialized [pp_rv2hv] + my $a = undef ; my %b = %$a + + Odd number of elements in hash list [pp_aassign] + %X = (1,2,3) ; + + Reference found where even-sized list expected [pp_aassign] + $X = [ 1 ..3 ]; + + Filehandle %s opened only for output [Perl_do_readline] + open (FH, ">./xcv") ; + my $a = <FH> ; + + glob failed (can't start child: %s) [Perl_do_readline] <<TODO + + readline() on closed filehandle %s [Perl_do_readline] + close STDIN ; $a = <STDIN>; + + glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO + + Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] + sub fred { fred() if $a++ < 200} fred() + + Deep recursion on anonymous subroutine [Perl_sub_crush_depth] + $a = sub { &$a if $a++ < 200} &$a + + Possible Y2K bug: about to append an integer to '19' [pp_concat] + $x = "19$yy\n"; + +__END__ +# pp_hot.c [pp_print] +use warnings 'unopened' ; +$f = $a = "abc" ; +print $f $a; +no warnings 'unopened' ; +print $f $a; +EXPECT +Filehandle main::abc never opened at - line 4. +######## +# pp_hot.c [pp_print] +use warnings 'io' ; +print STDIN "anc"; +print <STDOUT>; +print <STDERR>; +open(FOO, ">&STDOUT") and print <FOO>; +print getc(STDERR); +print getc(FOO); +#################################################################### +# The next test is known to fail on some systems (Linux+old glibc, # +# old *BSDs, and NeXT, among others. # +# We skip it for now (on the grounds that it is "just" a warning). # +#################################################################### +#read(FOO,$_,1); +no warnings 'io' ; +print STDIN "anc"; +EXPECT +Filehandle main::STDIN opened only for input at - line 3. +Filehandle main::STDOUT opened only for output at - line 4. +Filehandle main::STDERR opened only for output at - line 5. +Filehandle main::FOO opened only for output at - line 6. +Filehandle main::STDERR opened only for output at - line 7. +Filehandle main::FOO opened only for output at - line 8. +######## +# pp_hot.c [pp_print] +use warnings 'closed' ; +close STDIN ; +print STDIN "anc"; +opendir STDIN, "."; +print STDIN "anc"; +closedir STDIN; +no warnings 'closed' ; +print STDIN "anc"; +opendir STDIN, "."; +print STDIN "anc"; +EXPECT +print() on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 6. + (Are you trying to call print() on dirhandle main::STDIN?) +######## +# pp_hot.c [pp_rv2av] +use warnings 'uninitialized' ; +my $a = undef ; +my @b = @$a; +no warnings 'uninitialized' ; +my @c = @$a; +EXPECT +Use of uninitialized value in array dereference at - line 4. +######## +# pp_hot.c [pp_rv2hv] +use warnings 'uninitialized' ; +my $a = undef ; +my %b = %$a; +no warnings 'uninitialized' ; +my %c = %$a; +EXPECT +Use of uninitialized value in hash dereference at - line 4. +######## +# pp_hot.c [pp_aassign] +use warnings 'misc' ; +my %X ; %X = (1,2,3) ; +no warnings 'misc' ; +my %Y ; %Y = (1,2,3) ; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp_hot.c [pp_aassign] +use warnings 'misc' ; +my %X ; %X = [1 .. 3] ; +no warnings 'misc' ; +my %Y ; %Y = [1 .. 3] ; +EXPECT +Reference found where even-sized list expected at - line 3. +######## +# pp_hot.c [Perl_do_readline] +use warnings 'closed' ; +close STDIN ; $a = <STDIN> ; +opendir STDIN, "." ; $a = <STDIN> ; +closedir STDIN; +no warnings 'closed' ; +opendir STDIN, "." ; $a = <STDIN> ; +$a = <STDIN> ; +EXPECT +readline() on closed filehandle main::STDIN at - line 3. +readline() on closed filehandle main::STDIN at - line 4. + (Are you trying to call readline() on dirhandle main::STDIN?) +######## +# pp_hot.c [Perl_do_readline] +use warnings 'io' ; +my $file = "./xcv" ; unlink $file ; +open (FH, ">./xcv") ; +my $a = <FH> ; +no warnings 'io' ; +$a = <FH> ; +unlink $file ; +EXPECT +Filehandle main::FH opened only for output at - line 5. +######## +# pp_hot.c [Perl_sub_crush_depth] +use warnings 'recursion' ; +sub fred +{ + fred() if $a++ < 200 +} +{ + local $SIG{__WARN__} = sub { + die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ + }; + fred(); +} +EXPECT +ok +######## +# pp_hot.c [Perl_sub_crush_depth] +no warnings 'recursion' ; +sub fred +{ + fred() if $a++ < 200 +} +{ + local $SIG{__WARN__} = sub { + die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ + }; + fred(); +} +EXPECT + +######## +# pp_hot.c [Perl_sub_crush_depth] +use warnings 'recursion' ; +$b = sub +{ + &$b if $a++ < 200 +} ; + +&$b ; +EXPECT +Deep recursion on anonymous subroutine at - line 5. +######## +# pp_hot.c [Perl_sub_crush_depth] +no warnings 'recursion' ; +$b = sub +{ + &$b if $a++ < 200 +} ; + +&$b ; +EXPECT +######## +# pp_hot.c [pp_concat] +use warnings 'y2k'; +use Config; +BEGIN { + unless ($Config{ccflags} =~ /Y2KWARN/) { + print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; + exit 0; + } +} +my $x; +my $yy = 78; +$x = "19$yy\n"; +$x = "19" . $yy . "\n"; +$x = "319$yy\n"; +$x = "319" . $yy . "\n"; +no warnings 'y2k'; +$x = "19$yy\n"; +$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. diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys new file mode 100644 index 0000000..7c38727 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_sys @@ -0,0 +1,354 @@ + pp_sys.c AOK + + untie attempted while %d inner references still exist [pp_untie] + sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; + + Filehandle %s opened only for input [pp_leavewrite] + format STDIN = + . + write STDIN; + + write() on closed filehandle %s [pp_leavewrite] + format STDIN = + . + close STDIN; + write STDIN ; + + page overflow [pp_leavewrite] + + Filehandle %s never opened [pp_prtf] + $a = "abc"; printf $a "fred" + + Filehandle %s opened only for input [pp_prtf] + $a = "abc"; + printf $a "fred" + + printf() on closed filehandle %s [pp_prtf] + close STDIN ; + printf STDIN "fred" + + syswrite() on closed filehandle %s [pp_send] + close STDIN; + syswrite STDIN, "fred", 1; + + send() on closed socket %s [pp_send] + close STDIN; + send STDIN, "fred", 1 + + bind() on closed socket %s [pp_bind] + close STDIN; + bind STDIN, "fred" ; + + + connect() on closed socket %s [pp_connect] + close STDIN; + connect STDIN, "fred" ; + + listen() on closed socket %s [pp_listen] + close STDIN; + listen STDIN, 2; + + accept() on closed socket %s [pp_accept] + close STDIN; + accept "fred", STDIN ; + + shutdown() on closed socket %s [pp_shutdown] + close STDIN; + shutdown STDIN, 0; + + setsockopt() on closed socket %s [pp_ssockopt] + getsockopt() on closed socket %s [pp_ssockopt] + close STDIN; + setsockopt STDIN, 1,2,3; + getsockopt STDIN, 1,2; + + getsockname() on closed socket %s [pp_getpeername] + getpeername() on closed socket %s [pp_getpeername] + close STDIN; + getsockname STDIN; + getpeername STDIN; + + flock() on closed socket %s [pp_flock] + close STDIN; + flock STDIN, 8; + + warn(warn_nl, "stat"); [pp_stat] + + Test on unopened file <%s> + close STDIN ; -T STDIN ; + + warn(warn_nl, "open"); [pp_fttext] + -T "abc\ndef" ; + + Filehandle %s opened only for output [pp_sysread] + my $file = "./xcv" ; + open(F, ">$file") ; + my $a = sysread(F, $a,10) ; + + + +__END__ +# pp_sys.c [pp_untie] +use warnings 'untie' ; +sub TIESCALAR { bless [] } ; +$b = tie $a, 'main'; +untie $a ; +no warnings 'untie' ; +$c = tie $d, 'main'; +untie $d ; +EXPECT +untie attempted while 1 inner references still exist at - line 5. +######## +# pp_sys.c [pp_leavewrite] +use warnings 'io' ; +format STDIN = +. +write STDIN; +no warnings 'io' ; +write STDIN; +EXPECT +Filehandle main::STDIN opened only for input at - line 5. +######## +# pp_sys.c [pp_leavewrite] +use warnings 'closed' ; +format STDIN = +. +close STDIN; +write STDIN; +opendir STDIN, "."; +write STDIN; +closedir STDIN; +no warnings 'closed' ; +write STDIN; +opendir STDIN, "."; +write STDIN; +EXPECT +write() on closed filehandle main::STDIN at - line 6. +write() on closed filehandle main::STDIN at - line 8. + (Are you trying to call write() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_leavewrite] +use warnings 'io' ; +format STDOUT_TOP = +abc +. +format STDOUT = +def +ghi +. +$= = 1 ; +$- =1 ; +open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; +write ; +no warnings 'io' ; +write ; +EXPECT +page overflow at - line 13. +######## +# pp_sys.c [pp_prtf] +use warnings 'unopened' ; +$a = "abc"; +printf $a "fred"; +no warnings 'unopened' ; +printf $a "fred"; +EXPECT +Filehandle main::abc never opened at - line 4. +######## +# pp_sys.c [pp_prtf] +use warnings 'closed' ; +close STDIN ; +printf STDIN "fred"; +opendir STDIN, "."; +printf STDIN "fred"; +closedir STDIN; +no warnings 'closed' ; +printf STDIN "fred"; +opendir STDIN, "."; +printf STDIN "fred"; +EXPECT +printf() on closed filehandle main::STDIN at - line 4. +printf() on closed filehandle main::STDIN at - line 6. + (Are you trying to call printf() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_prtf] +use warnings 'io' ; +printf STDIN "fred"; +no warnings 'io' ; +printf STDIN "fred"; +EXPECT +Filehandle main::STDIN opened only for input at - line 3. +######## +# pp_sys.c [pp_send] +use warnings 'closed' ; +close STDIN; +syswrite STDIN, "fred", 1; +opendir STDIN, "."; +syswrite STDIN, "fred", 1; +closedir STDIN; +no warnings 'closed' ; +syswrite STDIN, "fred", 1; +opendir STDIN, "."; +syswrite STDIN, "fred", 1; +EXPECT +syswrite() on closed filehandle main::STDIN at - line 4. +syswrite() on closed filehandle main::STDIN at - line 6. + (Are you trying to call syswrite() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_flock] +use Config; +BEGIN { + if ( $^O eq 'VMS' and ! $Config{d_flock}) { + print <<EOM ; +SKIPPED +# flock not present +EOM + exit ; + } +} +use warnings 'closed' ; +close STDIN; +flock STDIN, 8; +opendir STDIN, "."; +flock STDIN, 8; +no warnings 'closed' ; +flock STDIN, 8; +opendir STDIN, "."; +flock STDIN, 8; +EXPECT +flock() on closed filehandle main::STDIN at - line 14. +flock() on closed filehandle main::STDIN at - line 16. + (Are you trying to call flock() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] +use warnings 'io' ; +use Config; +BEGIN { + if ( $^O ne 'VMS' and ! $Config{d_socket}) { + print <<EOM ; +SKIPPED +# send not present +# bind not present +# connect not present +# accept not present +# shutdown not present +# setsockopt not present +# getsockopt not present +# getsockname not present +# getpeername not present +EOM + exit ; + } +} +close STDIN; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +opendir STDIN, "."; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +closedir STDIN; +no warnings 'io' ; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept STDIN, "fred" ; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +opendir STDIN, "."; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +EXPECT +send() on closed socket main::STDIN at - line 22. +bind() on closed socket main::STDIN at - line 23. +connect() on closed socket main::STDIN at - line 24. +listen() on closed socket main::STDIN at - line 25. +accept() on closed socket main::STDIN at - line 26. +shutdown() on closed socket main::STDIN at - line 27. +setsockopt() on closed socket main::STDIN at - line 28. +getsockopt() on closed socket main::STDIN at - line 29. +getsockname() on closed socket main::STDIN at - line 30. +getpeername() on closed socket main::STDIN at - line 31. +send() on closed socket main::STDIN at - line 33. + (Are you trying to call send() on dirhandle main::STDIN?) +bind() on closed socket main::STDIN at - line 34. + (Are you trying to call bind() on dirhandle main::STDIN?) +connect() on closed socket main::STDIN at - line 35. + (Are you trying to call connect() on dirhandle main::STDIN?) +listen() on closed socket main::STDIN at - line 36. + (Are you trying to call listen() on dirhandle main::STDIN?) +accept() on closed socket main::STDIN at - line 37. + (Are you trying to call accept() on dirhandle main::STDIN?) +shutdown() on closed socket main::STDIN at - line 38. + (Are you trying to call shutdown() on dirhandle main::STDIN?) +setsockopt() on closed socket main::STDIN at - line 39. + (Are you trying to call setsockopt() on dirhandle main::STDIN?) +getsockopt() on closed socket main::STDIN at - line 40. + (Are you trying to call getsockopt() on dirhandle main::STDIN?) +getsockname() on closed socket main::STDIN at - line 41. + (Are you trying to call getsockname() on dirhandle main::STDIN?) +getpeername() on closed socket main::STDIN at - line 42. + (Are you trying to call getpeername() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_stat] +use warnings 'newline' ; +stat "abc\ndef"; +no warnings 'newline' ; +stat "abc\ndef"; +EXPECT +Unsuccessful stat on filename containing newline at - line 3. +######## +# pp_sys.c [pp_fttext] +use warnings 'unopened' ; +close STDIN ; +-T STDIN ; +no warnings 'unopened' ; +-T STDIN ; +EXPECT +Test on unopened file <STDIN> at - line 4. +######## +# pp_sys.c [pp_fttext] +use warnings 'newline' ; +-T "abc\ndef" ; +no warnings 'newline' ; +-T "abc\ndef" ; +EXPECT +Unsuccessful open on filename containing newline at - line 3. +######## +# pp_sys.c [pp_sysread] +use warnings 'io' ; +my $file = "./xcv" ; +open(F, ">$file") ; +my $a = sysread(F, $a,10) ; +no warnings 'io' ; +my $a = sysread(F, $a,10) ; +close F ; +unlink $file ; +EXPECT +Filehandle main::F opened only for output at - line 5. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp new file mode 100644 index 0000000..5d0c291 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/regcomp @@ -0,0 +1,165 @@ + regcomp.c AOK + + Strange *+?{} on zero-length expression [S_study_chunk] + /(?=a)?/ + + %.*s matches null string many times [S_regpiece] + $a = "ABC123" ; $a =~ /(?=a)*/' + + /%.127s/: Unrecognized escape \\%c passed through [S_regatom] + $x = '\m' ; /$x/ + + Character class [:%.*s:] unknown [S_regpposixcc] + + Character class syntax [. .] is reserved for future extensions [S_regpposixcc] + + Character class syntax [= =] is reserved for future extensions [S_checkposixcc] + + Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] + + /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] + + /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8] + + /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass] + + /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8] + +__END__ +# regcomp.c [S_regpiece] +use warnings 'regexp' ; +my $a = "ABC123" ; +$a =~ /(?=a)*/ ; +no warnings 'regexp' ; +$a =~ /(?=a)*/ ; +EXPECT +(?=a)* matches null string many times at - line 4. +######## +# regcomp.c [S_study_chunk] +use warnings 'regexp' ; +$_ = "" ; +/(?=a)?/; +no warnings 'regexp' ; +/(?=a)?/; +EXPECT +Strange *+?{} on zero-length expression at - line 4. +######## +# regcomp.c [S_regatom] +$x = '\m' ; +use warnings 'regexp' ; +$a =~ /a$x/ ; +no warnings 'regexp' ; +$a =~ /a$x/ ; +EXPECT +/a\m/: Unrecognized escape \m passed through at - line 4. +######## +# regcomp.c [S_regpposixcc S_checkposixcc] +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +use warnings 'regexp' ; +$_ = "" ; +/[:alpha:]/; +/[.bar.]/; +/[=zog=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[:zog:]/; +/[[:zog:]]/; +no warnings 'regexp' ; +/[:alpha:]/; +/[.foo.]/; +/[=bar=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[[:zog:]]/; +/[:zog:]/; +EXPECT +Character class syntax [: :] belongs inside character classes at - line 5. +Character class syntax [. .] belongs inside character classes at - line 6. +Character class syntax [. .] is reserved for future extensions at - line 6. +Character class syntax [= =] belongs inside character classes at - line 7. +Character class syntax [= =] is reserved for future extensions at - line 7. +Character class syntax [. .] is reserved for future extensions at - line 9. +Character class syntax [= =] is reserved for future extensions at - line 10. +Character class syntax [: :] belongs inside character classes at - line 11. +Character class [:zog:] unknown at - line 12. +######## +# regcomp.c [S_regclass] +$_ = ""; +use warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +no warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +EXPECT +/[a-\d]/: false [] range "a-\d" in regexp at - line 5. +/[\d-b]/: false [] range "\d-" in regexp at - line 6. +/[\s-\d]/: false [] range "\s-" in regexp at - line 7. +/[\d-\s]/: false [] range "\d-" in regexp at - line 8. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. +######## +# regcomp.c [S_regclassutf8] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic regular expression ranges differ."; + exit 0; + } +} +use utf8; +$_ = ""; +use warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +no warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +EXPECT +/[a-\d]/: false [] range "a-\d" in regexp at - line 12. +/[\d-b]/: false [] range "\d-" in regexp at - line 13. +/[\s-\d]/: false [] range "\s-" in regexp at - line 14. +/[\d-\s]/: false [] range "\d-" in regexp at - line 15. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19. +######## +# regcomp.c [S_regclass S_regclassutf8] +use warnings 'regexp' ; +$a =~ /[a\zb]/ ; +no warnings 'regexp' ; +$a =~ /[a\zb]/ ; +EXPECT +/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3. diff --git a/contrib/perl5/t/pragma/warn/regexec b/contrib/perl5/t/pragma/warn/regexec new file mode 100644 index 0000000..73696df --- /dev/null +++ b/contrib/perl5/t/pragma/warn/regexec @@ -0,0 +1,119 @@ + regexec.c + + This test generates "bad free" warnings when run under + PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder + for investigation. + + Complex regular subexpression recursion limit (%d) exceeded + + $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; + Complex regular subexpression recursion limit (%d) exceeded + + $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; + + (The actual value substituted for %d is masked in the tests so that + REG_INFTY configuration variable value does not affect outcome.) +__END__ +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +use warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT +Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +use warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*?$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT +Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*?$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/run b/contrib/perl5/t/pragma/warn/run new file mode 100644 index 0000000..7a4be20 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/run @@ -0,0 +1,8 @@ + run.c + + + Mandatory Warnings ALL TODO + ------------------ + NULL OP IN RUN + +__END__ diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv new file mode 100644 index 0000000..758137f --- /dev/null +++ b/contrib/perl5/t/pragma/warn/sv @@ -0,0 +1,303 @@ + sv.c + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + warn(warn_uninit); + + Subroutine %s redefined + + Invalid conversion in %s: + + Undefined value assigned to typeglob + + Possible Y2K bug: %d format string following '19' + + Reference is already weak [Perl_sv_rvweaken] <<TODO + + Mandatory Warnings + ------------------ + Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce + with perl now) + + Mandatory Warnings TODO + ------------------ + Attempt to free non-arena SV: 0x%lx [del_sv] + Reference miscount in sv_replace() [sv_replace] + Attempt to free unreferenced scalar [sv_free] + Attempt to free temp prematurely: SV 0x%lx [sv_free] + semi-panic: attempt to dup freed string [newSVsv] + + +__END__ +# sv.c +use integer ; +use warnings 'uninitialized' ; +$x = 1 + $a[0] ; # a +no warnings 'uninitialized' ; +$x = 1 + $b[0] ; # a +EXPECT +Use of uninitialized value in integer addition (+) at - line 4. +######## +# sv.c (sv_2iv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use integer ; +use warnings 'uninitialized' ; +$A *= 2 ; +no warnings 'uninitialized' ; +$A *= 2 ; +EXPECT +Use of uninitialized value in integer multiplication (*) at - line 10. +######## +# sv.c +use integer ; +use warnings 'uninitialized' ; +my $x *= 2 ; #b +no warnings 'uninitialized' ; +my $y *= 2 ; #b +EXPECT +Use of uninitialized value in integer multiplication (*) at - line 4. +######## +# sv.c (sv_2uv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$B = 0 ; +$B |= $A ; +no warnings 'uninitialized' ; +$B = 0 ; +$B |= $A ; +EXPECT +Use of uninitialized value in bitwise or (|) at - line 10. +######## +# sv.c +use warnings 'uninitialized' ; +my $Y = 1 ; +my $x = 1 | $a[$Y] ; +no warnings 'uninitialized' ; +my $Y = 1 ; +$x = 1 | $b[$Y] ; +EXPECT +Use of uninitialized value in bitwise or (|) at - line 4. +######## +# sv.c +use warnings 'uninitialized' ; +my $x *= 1 ; # d +no warnings 'uninitialized' ; +my $y *= 1 ; # d +EXPECT +Use of uninitialized value in multiplication (*) at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = 1 + $a[0] ; # e +no warnings 'uninitialized' ; +$x = 1 + $b[0] ; # e +EXPECT +Use of uninitialized value in addition (+) at - line 3. +######## +# sv.c (sv_2nv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$A *= 2 ; +no warnings 'uninitialized' ; +$A *= 2 ; +EXPECT +Use of uninitialized value in multiplication (*) at - line 9. +######## +# sv.c +use warnings 'uninitialized' ; +$x = $y + 1 ; # f +no warnings 'uninitialized' ; +$x = $z + 1 ; # f +EXPECT +Use of uninitialized value in addition (+) at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = chop undef ; # g +no warnings 'uninitialized' ; +$x = chop undef ; # g +EXPECT +Modification of a read-only value attempted at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = chop $y ; # h +no warnings 'uninitialized' ; +$x = chop $z ; # h +EXPECT +Use of uninitialized value in scalar chop at - line 3. +######## +# sv.c (sv_2pv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$B = "" ; +$B .= $A ; +no warnings 'uninitialized' ; +$C = "" ; +$C .= $A ; +EXPECT +Use of uninitialized value in concatenation (.) at - line 10. +######## +# sv.c +use warnings 'numeric' ; +sub TIESCALAR{bless[]} ; +sub FETCH {"def"} ; +tie $a,"main" ; +my $b = 1 + $a; +no warnings 'numeric' ; +my $c = 1 + $a; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 6. +######## +# sv.c +use warnings 'numeric' ; +my $x = 1 + "def" ; +no warnings 'numeric' ; +my $z = 1 + "def" ; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 3. +######## +# sv.c +use warnings 'numeric' ; +my $a = "def" ; +my $x = 1 + $a ; +no warnings 'numeric' ; +my $y = 1 + $a ; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 4. +######## +# sv.c +use warnings 'numeric' ; use integer ; +my $a = "def" ; +my $x = 1 + $a ; +no warnings 'numeric' ; +my $z = 1 + $a ; +EXPECT +Argument "def" isn't numeric in integer addition (+) at - line 4. +######## +# sv.c +use warnings 'numeric' ; +my $x = 1 & "def" ; +no warnings 'numeric' ; +my $z = 1 & "def" ; +EXPECT +Argument "def" isn't numeric in bitwise and (&) at - line 3. +######## +# sv.c +use warnings 'redefine' ; +sub fred {} +sub joe {} +*fred = \&joe ; +no warnings 'redefine' ; +sub jim {} +*jim = \&joe ; +EXPECT +Subroutine fred redefined at - line 5. +######## +# sv.c +use warnings 'printf' ; +open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; +printf F "%z\n" ; +my $a = sprintf "%z" ; +printf F "%" ; +$a = sprintf "%" ; +printf F "%\x02" ; +$a = sprintf "%\x02" ; +no warnings 'printf' ; +printf F "%z\n" ; +$a = sprintf "%z" ; +printf F "%" ; +$a = sprintf "%" ; +printf F "%\x02" ; +$a = sprintf "%\x02" ; +EXPECT +Invalid conversion in sprintf: "%z" at - line 5. +Invalid conversion in sprintf: end of string at - line 7. +Invalid conversion in sprintf: "%\002" at - line 9. +Invalid conversion in printf: "%z" at - line 4. +Invalid conversion in printf: end of string at - line 6. +Invalid conversion in printf: "%\002" at - line 8. +######## +# sv.c +use warnings 'misc' ; +*a = undef ; +no warnings 'misc' ; +*b = undef ; +EXPECT +Undefined value assigned to typeglob at - line 3. +######## +# sv.c +use warnings 'y2k'; +use Config; +BEGIN { + unless ($Config{ccflags} =~ /Y2KWARN/) { + print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; + exit 0; + } + $|=1; +} +my $x; +my $yy = 78; +$x = printf "19%02d\n", $yy; +$x = sprintf "#19%02d\n", $yy; +$x = printf " 19%02d\n", 78; +$x = sprintf "19%02d\n", 78; +$x = printf "319%02d\n", $yy; +$x = sprintf "319%02d\n", $yy; +no warnings 'y2k'; +$x = printf "19%02d\n", $yy; +$x = sprintf "19%02d\n", $yy; +$x = printf "19%02d\n", 78; +$x = sprintf "19%02d\n", 78; +EXPECT +Possible Y2K bug: %d format string following '19' at - line 16. +Possible Y2K bug: %d format string following '19' at - line 13. +1978 +Possible Y2K bug: %d format string following '19' at - line 14. +Possible Y2K bug: %d format string following '19' at - line 15. + 1978 +31978 +1978 +1978 diff --git a/contrib/perl5/t/pragma/warn/taint b/contrib/perl5/t/pragma/warn/taint new file mode 100644 index 0000000..fd6deed --- /dev/null +++ b/contrib/perl5/t/pragma/warn/taint @@ -0,0 +1,49 @@ + taint.c AOK + + Insecure %s%s while running with -T switch + +__END__ +-T +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; +EXPECT +Insecure dependency in chdir while running with -T switch at - line 5. +######## +-TU +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; +EXPECT +xxx +######## +-TU +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +use warnings 'taint' ; +chdir $a ; +print "xxx\n" ; +no warnings 'taint' ; +chdir $a ; +print "yyy\n" ; +EXPECT +Insecure dependency in chdir while running with -T switch at - line 6. +xxx +yyy diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke new file mode 100644 index 0000000..cfdea78 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/toke @@ -0,0 +1,583 @@ +toke.c AOK + + we seem to have lost a few ambiguous warnings!! + + + 1 if $a EQ $b ; + 1 if $a NE $b ; + 1 if $a LT $b ; + 1 if $a GT $b ; + 1 if $a GE $b ; + 1 if $a LE $b ; + $a = <<; + Use of comma-less variable list is deprecated + (called 3 times via depcom) + + \1 better written as $1 + use warnings 'syntax' ; + s/(abc)/\1/; + + warn(warn_nosemi) + Semicolon seems to be missing + $a = 1 + &time ; + + + Reversed %c= operator + my $a =+ 2 ; + $a =- 2 ; + $a =* 2 ; + $a =% 2 ; + $a =& 2 ; + $a =. 2 ; + $a =^ 2 ; + $a =| 2 ; + $a =< 2 ; + $a =/ 2 ; + + Multidimensional syntax %.*s not supported + my $a = $a[1,2] ; + + You need to quote \"%s\"" + sub fred {} ; $SIG{TERM} = fred; + + Scalar value %.*s better written as $%.*s" + @a[3] = 2; + @a{3} = 2; + + Can't use \\%c to mean $%c in expression + $_ = "ab" ; s/(ab)/\1/e; + + Unquoted string "abc" may clash with future reserved word at - line 3. + warn(warn_reserved + $a = abc; + + chmod() mode argument is missing initial 0 + chmod 3; + + Possible attempt to separate words with commas + @a = qw(a, b, c) ; + + Possible attempt to put comments in qw() list + @a = qw(a b # c) ; + + umask: argument is missing initial 0 + umask 3; + + %s (...) interpreted as function + print ("") + printf ("") + sort ("") + + Ambiguous use of %c{%s%s} resolved to %c%s%s + $a = ${time[2]} + $a = ${time{2}} + + + Ambiguous use of %c{%s} resolved to %c%s + $a = ${time} + sub fred {} $a = ${fred} + + Misplaced _ in number + $a = 1_2; + $a = 1_2345_6; + + Bareword \"%s\" refers to nonexistent package + $a = FRED:: ; + + Ambiguous call resolved as CORE::%s(), qualify as such or use & + sub time {} + my $a = time() + + Unrecognized escape \\%c passed through + $a = "\m" ; + + %s number > %s non-portable + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; + + Integer overflow in binary number + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; + + Mandatory Warnings + ------------------ + Use of "%s" without parentheses is ambiguous [check_uni] + rand + 4 + + Ambiguous use of -%s resolved as -&%s() [yylex] + sub fred {} ; - fred ; + + Precedence problem: open %.*s should be open(%.*s) [yylex] + open FOO || die; + + Operator or semicolon missing before %c%s [yylex] + Ambiguous use of %c resolved as operator %c + *foo *foo + +__END__ +# toke.c +use warnings 'deprecated' ; +1 if $a EQ $b ; +1 if $a NE $b ; +1 if $a GT $b ; +1 if $a LT $b ; +1 if $a GE $b ; +1 if $a LE $b ; +no warnings 'deprecated' ; +1 if $a EQ $b ; +1 if $a NE $b ; +1 if $a GT $b ; +1 if $a LT $b ; +1 if $a GE $b ; +1 if $a LE $b ; +EXPECT +Use of EQ is deprecated at - line 3. +Use of NE is deprecated at - line 4. +Use of GT is deprecated at - line 5. +Use of LT is deprecated at - line 6. +Use of GE is deprecated at - line 7. +Use of LE is deprecated at - line 8. +######## +# toke.c +use warnings 'deprecated' ; +format STDOUT = +@<<< @||| @>>> @>>> +$a $b "abc" 'def' +. +no warnings 'deprecated' ; +format STDOUT = +@<<< @||| @>>> @>>> +$a $b "abc" 'def' +. +EXPECT +Use of comma-less variable list is deprecated at - line 5. +Use of comma-less variable list is deprecated at - line 5. +Use of comma-less variable list is deprecated at - line 5. +######## +# toke.c +use warnings 'deprecated' ; +$a = <<; + +no warnings 'deprecated' ; +$a = <<; + +EXPECT +Use of bare << to mean <<"" is deprecated at - line 3. +######## +# toke.c +use warnings 'syntax' ; +s/(abc)/\1/; +no warnings 'syntax' ; +s/(abc)/\1/; +EXPECT +\1 better written as $1 at - line 3. +######## +# toke.c +use warnings 'semicolon' ; +$a = 1 +&time ; +no warnings 'semicolon' ; +$a = 1 +&time ; +EXPECT +Semicolon seems to be missing at - line 3. +######## +# toke.c +BEGIN { + # Scalars leaked: due to syntax errors + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +use warnings 'syntax' ; +my $a =+ 2 ; +$a =- 2 ; +$a =* 2 ; +$a =% 2 ; +$a =& 2 ; +$a =. 2 ; +$a =^ 2 ; +$a =| 2 ; +$a =< 2 ; +$a =/ 2 ; +EXPECT +Reversed += operator at - line 7. +Reversed -= operator at - line 8. +Reversed *= operator at - line 9. +Reversed %= operator at - line 10. +Reversed &= operator at - line 11. +Reversed .= operator at - line 12. +syntax error at - line 12, near "=." +Reversed ^= operator at - line 13. +syntax error at - line 13, near "=^" +Reversed |= operator at - line 14. +syntax error at - line 14, near "=|" +Reversed <= operator at - line 15. +Unterminated <> operator at - line 15. +######## +# toke.c +BEGIN { + # Scalars leaked: due to syntax errors + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +no warnings 'syntax' ; +my $a =+ 2 ; +$a =- 2 ; +$a =* 2 ; +$a =% 2 ; +$a =& 2 ; +$a =. 2 ; +$a =^ 2 ; +$a =| 2 ; +$a =< 2 ; +$a =/ 2 ; +EXPECT +syntax error at - line 12, near "=." +syntax error at - line 13, near "=^" +syntax error at - line 14, near "=|" +Unterminated <> operator at - line 15. +######## +# toke.c +use warnings 'syntax' ; +my $a = $a[1,2] ; +no warnings 'syntax' ; +my $a = $a[1,2] ; +EXPECT +Multidimensional syntax $a[1,2] not supported at - line 3. +######## +# toke.c +use warnings 'syntax' ; +sub fred {} ; $SIG{TERM} = fred; +no warnings 'syntax' ; +$SIG{TERM} = fred; +EXPECT +You need to quote "fred" at - line 3. +######## +# toke.c +use warnings 'syntax' ; +@a[3] = 2; +@a{3} = 2; +no warnings 'syntax' ; +@a[3] = 2; +@a{3} = 2; +EXPECT +Scalar value @a[3] better written as $a[3] at - line 3. +Scalar value @a{3} better written as $a{3} at - line 4. +######## +# toke.c +use warnings 'syntax' ; +$_ = "ab" ; +s/(ab)/\1/e; +no warnings 'syntax' ; +$_ = "ab" ; +s/(ab)/\1/e; +EXPECT +Can't use \1 to mean $1 in expression at - line 4. +######## +# toke.c +use warnings 'reserved' ; +$a = abc; +no warnings 'reserved' ; +$a = abc; +EXPECT +Unquoted string "abc" may clash with future reserved word at - line 3. +######## +# toke.c +use warnings 'chmod' ; +chmod 3; +no warnings 'chmod' ; +chmod 3; +EXPECT +chmod() mode argument is missing initial 0 at - line 3. +######## +# toke.c +use warnings 'qw' ; +@a = qw(a, b, c) ; +no warnings 'qw' ; +@a = qw(a, b, c) ; +EXPECT +Possible attempt to separate words with commas at - line 3. +######## +# toke.c +use warnings 'qw' ; +@a = qw(a b #) ; +no warnings 'qw' ; +@a = qw(a b #) ; +EXPECT +Possible attempt to put comments in qw() list at - line 3. +######## +# toke.c +use warnings 'umask' ; +umask 3; +no warnings 'umask' ; +umask 3; +EXPECT +umask: argument is missing initial 0 at - line 3. +######## +# toke.c +use warnings 'syntax' ; +print ("") +EXPECT +print (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +print ("") +EXPECT + +######## +# toke.c +use warnings 'syntax' ; +printf ("") +EXPECT +printf (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +printf ("") +EXPECT + +######## +# toke.c +use warnings 'syntax' ; +sort ("") +EXPECT +sort (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +sort ("") +EXPECT + +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time[2]}; +no warnings 'ambiguous' ; +$a = ${time[2]}; +EXPECT +Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time{2}}; +EXPECT +Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. +######## +# toke.c +no warnings 'ambiguous' ; +$a = ${time{2}}; +EXPECT + +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time} ; +no warnings 'ambiguous' ; +$a = ${time} ; +EXPECT +Ambiguous use of ${time} resolved to $time at - line 3. +######## +# toke.c +use warnings 'ambiguous' ; +sub fred {} +$a = ${fred} ; +no warnings 'ambiguous' ; +$a = ${fred} ; +EXPECT +Ambiguous use of ${fred} resolved to $fred at - line 4. +######## +# toke.c +use warnings 'syntax' ; +$a = 1_2; +$a = 1_2345_6; +no warnings 'syntax' ; +$a = 1_2; +$a = 1_2345_6; +EXPECT +Misplaced _ in number at - line 3. +Misplaced _ in number at - line 4. +Misplaced _ in number at - line 4. +######## +# toke.c +use warnings 'bareword' ; +#line 25 "bar" +$a = FRED:: ; +no warnings 'bareword' ; +#line 25 "bar" +$a = FRED:: ; +EXPECT +Bareword "FRED::" refers to nonexistent package at bar line 25. +######## +# toke.c +use warnings 'ambiguous' ; +sub time {} +my $a = time() ; +no warnings 'ambiguous' ; +my $b = time() ; +EXPECT +Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. +######## +# toke.c +use warnings ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE +EXPECT + +######## +# toke.c +my $a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 2. +######## +# toke.c +$^W = 0 ; +my $a = rand + 4 ; +{ + no warnings 'ambiguous' ; + $a = rand + 4 ; + use warnings 'ambiguous' ; + $a = rand + 4 ; +} +$a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 3. +Warning: Use of "rand" without parens is ambiguous at - line 8. +Warning: Use of "rand" without parens is ambiguous at - line 10. +######## +# toke.c +sub fred {}; +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 3. +######## +# toke.c +$^W = 0 ; +sub fred {} ; +-fred ; +{ + no warnings 'ambiguous' ; + -fred ; + use warnings 'ambiguous' ; + -fred ; +} +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 4. +Ambiguous use of -fred resolved as -&fred() at - line 9. +Ambiguous use of -fred resolved as -&fred() at - line 11. +######## +# toke.c +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 2. +######## +# toke.c +$^W = 0 ; +open FOO || time; +{ + no warnings 'precedence' ; + open FOO || time; + use warnings 'precedence' ; + open FOO || time; +} +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 3. +Precedence problem: open FOO should be open(FOO) at - line 8. +Precedence problem: open FOO should be open(FOO) at - line 10. +######## +# toke.c +$^W = 0 ; +*foo *foo ; +{ + no warnings 'ambiguous' ; + *foo *foo ; + use warnings 'ambiguous' ; + *foo *foo ; +} +*foo *foo ; +EXPECT +Operator or semicolon missing before *foo at - line 3. +Ambiguous use of * resolved as operator * at - line 3. +Operator or semicolon missing before *foo at - line 8. +Ambiguous use of * resolved as operator * at - line 8. +Operator or semicolon missing before *foo at - line 10. +Ambiguous use of * resolved as operator * at - line 10. +######## +# toke.c +use warnings 'misc' ; +my $a = "\m" ; +no warnings 'misc' ; +$a = "\m" ; +EXPECT +Unrecognized escape \m passed through at - line 3. +######## +# toke.c +use warnings 'portable' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +no warnings 'portable' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +Hexadecimal number > 0xffffffff non-portable at - line 8. +Octal number > 037777777777 non-portable at - line 11. +######## +# toke.c +use warnings 'overflow' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x10000000000000000 ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 002000000000000000000000; +no warnings 'overflow' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x10000000000000000 ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 002000000000000000000000; +EXPECT +Integer overflow in binary number at - line 5. +Integer overflow in hexadecimal number at - line 8. +Integer overflow in octal number at - line 11. diff --git a/contrib/perl5/t/pragma/warn/universal b/contrib/perl5/t/pragma/warn/universal new file mode 100644 index 0000000..6dbb1be --- /dev/null +++ b/contrib/perl5/t/pragma/warn/universal @@ -0,0 +1,16 @@ + universal.c AOK + + Can't locate package %s for @%s::ISA [S_isa_lookup] + + + +__END__ +# universal.c [S_isa_lookup] +use warnings 'misc' ; +@ISA = qw(Joe) ; +my $a = bless [] ; +UNIVERSAL::isa $a, Jim ; +EXPECT +Can't locate package Joe for @main::ISA at - line 5. +Can't locate package Joe for @main::ISA. +Can't locate package Joe for @main::ISA. diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8 new file mode 100644 index 0000000..6a2fe54 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/utf8 @@ -0,0 +1,29 @@ + + utf8.c AOK + + [utf8_to_uv] + Malformed UTF-8 character + my $a = ord "\x80" ; + + Malformed UTF-8 character + my $a = ord "\xf080" ; + <<<<<< this warning can't be easily triggered from perl anymore + + [utf16_to_utf8] + Malformed UTF-16 surrogate + <<<<<< Add a test when somethig actually calls utf16_to_utf8 + +__END__ +# utf8.c [utf8_to_uv] -W +use utf8 ; +my $a = "snstorm" ; +{ + no warnings 'utf8' ; + my $a = "snstorm"; + use warnings 'utf8' ; + my $a = "snstorm"; +} +EXPECT +Malformed UTF-8 character at - line 3. +Malformed UTF-8 character at - line 8. +######## diff --git a/contrib/perl5/t/pragma/warn/util b/contrib/perl5/t/pragma/warn/util new file mode 100644 index 0000000..e82d6a6 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/util @@ -0,0 +1,108 @@ + util.c AOK + + Illegal octal digit ignored + my $a = oct "029" ; + + Illegal hex digit ignored + my $a = hex "0xv9" ; + + Illegal binary digit ignored + my $a = oct "0b9" ; + + Integer overflow in binary number + my $a = oct "0b111111111111111111111111111111111111111111" ; + Binary number > 0b11111111111111111111111111111111 non-portable + $a = oct "0b111111111111111111111111111111111" ; + Integer overflow in octal number + my $a = oct "077777777777777777777777777777" ; + Octal number > 037777777777 non-portable + $a = oct "0047777777777" ; + Integer overflow in hexadecimal number + my $a = hex "0xffffffffffffffffffff" ; + Hexadecimal number > 0xffffffff non-portable + $a = hex "0x1ffffffff" ; + +__END__ +# util.c +use warnings 'digit' ; +my $a = oct "029" ; +no warnings 'digit' ; +$a = oct "029" ; +EXPECT +Illegal octal digit '9' ignored at - line 3. +######## +# util.c +use warnings 'digit' ; +my $a = hex "0xv9" ; +no warnings 'digit' ; +$a = hex "0xv9" ; +EXPECT +Illegal hexadecimal digit 'v' ignored at - line 3. +######## +# util.c +use warnings 'digit' ; +my $a = oct "0b9" ; +no warnings 'digit' ; +$a = oct "0b9" ; +EXPECT +Illegal binary digit '9' ignored at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; +no warnings 'overflow' ; +$a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; +EXPECT +Integer overflow in binary number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = hex "0xffffffffffffffffffff" ; +no warnings 'overflow' ; +$a = hex "0xffffffffffffffffffff" ; +EXPECT +Integer overflow in hexadecimal number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "077777777777777777777777777777" ; +no warnings 'overflow' ; +$a = oct "077777777777777777777777777777" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +no warnings 'portable' ; + $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +no warnings 'portable' ; + $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +EXPECT +Hexadecimal number > 0xffffffff non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +no warnings 'portable' ; + $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +EXPECT +Octal number > 037777777777 non-portable at - line 5. diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t new file mode 100755 index 0000000..71fb0df --- /dev/null +++ b/contrib/perl5/t/pragma/warnings.t @@ -0,0 +1,121 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; + require Config; import Config; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; +my @w_files = () ; + +if (@ARGV) + { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV } +else + { @w_files = sort glob("pragma/warn/*") } + +foreach (@w_files) { + + next if /\.orig$/ ; + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `./perl "-I../lib" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `./perl -I../lib $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + # allow all tests to run when there are leaks + $results =~ s/Scalars leaked: \d+\n//g; + $expected =~ s/\n+$//; + my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; + # any special options? (OPTIONS foo bar zap) + my $option_regex = 0; + if ($expected =~ s/^OPTIONS? (.+)\n//) { + foreach my $option (split(' ', $1)) { + if ($option eq 'regex') { # allow regular expressions + $option_regex = 1; + } else { + die "$0: Unknown OPTION '$option'\n"; + } + } + } + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results !~ /^\Q$expected/))) or + (!$prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results ne $expected)))) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} |