diff options
| author | Nick Ing-Simmons <nik@tiuk.ti.com> | 1999-09-10 20:44:22 +0000 |
|---|---|---|
| committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 1999-09-10 20:44:22 +0000 |
| commit | 53e9df65959190f4cd34a02fe359bc5e6d2553f6 (patch) | |
| tree | 0808e1620b6ecdcd9f64c6db1b8f70966efe542e /t | |
| parent | a0ed51b321531af4b47cce24205ab9656f043f0f (diff) | |
| parent | 8a7fc0dc3015c8254ce4e866be71508e3379d45d (diff) | |
| download | perl-53e9df65959190f4cd34a02fe359bc5e6d2553f6.tar.gz | |
Get resolve -at mainline
p4raw-id: //depot/utfperl@4126
Diffstat (limited to 't')
261 files changed, 16972 insertions, 938 deletions
@@ -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,11 +43,22 @@ TESTING COMPILER -------------------------------------------------------------------------------- EOT + $ENV{PERLCC_TIMEOUT} = 120 + if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + $bad = 0; $good = 0; $total = @tests; $files = 0; $totmax = 0; + $maxlen = 0; + foreach (@tests) { + $len = length; + $maxlen = $len if $len > $maxlen; + } + # +3 : we want three dots between the test name and the "ok" + # -2 : the .t suffix + $dotdotdot = $maxlen + 3 - 2; while ($test = shift @tests) { if ( $infinite{$test} && $type eq 'compile' ) { @@ -59,7 +70,7 @@ EOT } $te = $test; chop($te); - print "$te" . '.' x (18 - length($te)); + print "$te" . '.' x ($dotdotdot - length($te)); open(SCRIPT,"<$test") or die "Can't run $test.\n"; $_ = <SCRIPT>; @@ -142,12 +153,12 @@ EOT } } else { - $pct = sprintf("%.2f", $good / $total * 100); + $pct = sprintf("%.2f", ($files - $bad) / $files * 100); 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 @@ -55,6 +55,9 @@ TESTING COMPILER -------------------------------------------------------------------------------- EOT + $ENV{PERLCC_TIMEOUT} = 120 + if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + $bad = 0; $good = 0; $total = @tests; diff --git a/t/base/lex.t b/t/base/lex.t index 045cb22eb0..d90d404cac 100755 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ - -print "1..30\n"; +print "1..46\n"; $x = 'x'; @@ -117,3 +115,94 @@ $foo =~ s/^not /substr(<<EOF, 0, 0)/e; Ignored 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 { + my ($where, $num) = @_; + my ($p,$f,$l) = caller; + print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/; + print "ok $num\n"; +} + +my $test = 42; + +{ +# line 42 "plink" + local $_ = "not ok "; + eval q{ + s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++; +# fuggedaboudit +EOT + print $_, $test++, "\n"; + T('^main:\(eval \d+\):6$', $test++); +# line 1 "plunk" + T('^main:plunk:1$', $test++); + }; + print "# $@\nnot ok $test\n" if $@; + T '^main:plink:53$', $test++; +} diff --git a/t/base/rs.t b/t/base/rs.t index 5428603304..021d699e2e 100755 --- a/t/base/rs.t +++ b/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";} @@ -85,6 +85,7 @@ $bar = <TESTFILE>; if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";} # Get rid of the temp file +close TESTFILE; unlink "./foo"; # Now for the tricky bit--full record reading @@ -120,8 +121,8 @@ if ($^O eq 'VMS') { $bar = <TESTFILE>; if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";} - unlink "./foo.bar"; - unlink "./foo.com"; + close TESTFILE; + 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/t/base/term.t b/t/base/term.t index 782ad397d3..638069482f 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -2,12 +2,22 @@ # $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Config; + print "1..7\n"; # check "" interpretation $x = "\n"; -if ($x eq chr(10)) {print "ok 1\n";} else {print "not ok 1\n";} +# 10 is ASCII/Iso Latin, 21 is EBCDIC. +if ($x eq chr(10) || + ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";} +else {print "not ok 1\n";} # check `` processing diff --git a/t/cmd/for.t b/t/cmd/for.t index e45f05040b..d70af579fc 100755 --- a/t/cmd/for.t +++ b/t/cmd/for.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $ - -print "1..7\n"; +print "1..10\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; @@ -47,3 +45,13 @@ if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";} foreach $foo (("ok 6\n","ok 7\n")) { print $foo; } + +sub foo { + for $i (1..5) { + return $i if $_[0] == $i; + } +} + +print foo(1) == 1 ? "ok" : "not ok", " 8\n"; +print foo(2) == 2 ? "ok" : "not ok", " 9\n"; +print foo(5) == 5 ? "ok" : "not ok", " 10\n"; diff --git a/t/cmd/subval.t b/t/cmd/subval.t index 3c1ffb89ea..3c60690ebf 100755 --- a/t/cmd/subval.t +++ b/t/cmd/subval.t @@ -33,7 +33,7 @@ sub foo6 { 'true2' unless $_[0]; } -print "1..34\n"; +print "1..36\n"; if (&foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";} if (&foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} @@ -177,3 +177,10 @@ sub iseof { eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n"; } } + +sub autov { $_[0] = 23 }; + +my $href = {}; +print keys %$href ? 'not ' : '', "ok 35\n"; +autov($href->{b}); +print join(':', %$href) eq 'b:23' ? '' : 'not ', "ok 36\n"; diff --git a/t/cmd/while.t b/t/cmd/while.t index c6e464d444..392c13779f 100755 --- a/t/cmd/while.t +++ b/t/cmd/while.t @@ -2,7 +2,7 @@ # $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $ -print "1..10\n"; +print "1..15\n"; open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; @@ -109,3 +109,22 @@ $i = 9; $i++; } print "ok $i\n"; + +# Check curpm is reset when jumping out of a scope +'abc' =~ /b/; +WHILE: +while (1) { + $i++; + print "#$`,$&,$',\nnot " unless $` . $& . $' eq "abc"; + print "ok $i\n"; + { # Localize changes to $` and friends + 'end' =~ /end/; + redo WHILE if $i == 11; + next WHILE if $i == 12; + # 13 do a normal loop + last WHILE if $i == 14; + } +} +$i++; +print "not " unless $` . $& . $' eq "abc"; +print "ok $i\n"; diff --git a/t/comp/bproto.t b/t/comp/bproto.t new file mode 100755 index 0000000000..699ea57a36 --- /dev/null +++ b/t/comp/bproto.t @@ -0,0 +1,41 @@ +#!./perl +# +# check if builtins behave as prototyped +# + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..7\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; +]; diff --git a/t/comp/colon.t b/t/comp/colon.t index d2c64fe4c5..dee5330ff2 100755 --- a/t/comp/colon.t +++ b/t/comp/colon.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; diff --git a/t/comp/cpp.t b/t/comp/cpp.t index 86e7359524..bbff38c553 100755 --- a/t/comp/cpp.t +++ b/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/t/comp/package.t b/t/comp/package.t index cef02c5cb4..4982256db7 100755 --- a/t/comp/package.t +++ b/t/comp/package.t @@ -1,6 +1,6 @@ #!./perl -print "1..7\n"; +print "1..8\n"; $blurfl = 123; $foo = 3; @@ -23,7 +23,11 @@ $main = join(':', sort(keys %main::)); $xyz = join(':', sort(keys %xyz::)); $ABC = join(':', sort(keys %ABC::)); -print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +if ('a' lt 'A') { + print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +} else { + print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; +} print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; @@ -33,3 +37,17 @@ print $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; print $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; + +package main; + +sub c { caller(0) } + +sub foo { + my $s = shift; + if ($s) { + package PQR; + main::c(); + } +} + +print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n"); diff --git a/t/comp/proto.t b/t/comp/proto.t index 6a59107ce7..6381facbea 100755 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -11,12 +11,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; -print "1..82\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 '$', @@ -413,3 +413,56 @@ sub X::foo4 ($); *X::foo4 = sub ($) {'ok'}; print "not " unless X->foo4 eq 'ok'; 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/t/comp/require.t b/t/comp/require.t index bae0712dfa..581dcba75c 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -2,22 +2,32 @@ BEGIN { chdir 't' if -d 't'; - @INC = ('.'); + unshift @INC, ('.', '../lib'); } # don't make this lexical $i = 1; -print "1..3\n"; +print "1..4\n"; sub do_require { %INC = (); - open(REQ,">bleah.pm") or die "Can't write 'bleah.pm': $!"; - print REQ @_; - close REQ; + write_file('bleah.pm',@_); eval { require "bleah.pm" }; my @a; # magic guard for scope violations (must be first lexical in file) } +sub write_file { + my $f = shift; + open(REQ,">$f") or die "Can't write '$f': $!"; + print REQ @_; + close REQ; +} + +# interaction with pod (see the eof) +write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); +require "bleah.pm"; +$i++; + # run-time failure in require do_require "0;\n"; print "# $@\nnot " unless $@ =~ /did not return a true/; @@ -25,7 +35,9 @@ print "ok ",$i++,"\n"; # compile-time failure in require do_require "1)\n"; -print "# $@\nnot " unless $@ =~ /syntax error/; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. +print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; print "ok ",$i++,"\n"; # successful require @@ -33,4 +45,8 @@ do_require "1"; print "# $@\nnot " if $@; print "ok ",$i++,"\n"; -unlink 'bleah.pm'; +END { 1 while unlink 'bleah.pm'; } + +# ***interaction with pod (don't put any thing after here)*** + +=pod diff --git a/t/comp/use.t b/t/comp/use.t index a6ce2a4d56..1099547393 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..14\n"; @@ -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/t/io/argv.t b/t/io/argv.t index d99865e142..c6565dc9c7 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $ +print "1..6\n"; -print "1..5\n"; - -open(try, '>Io.argv.tmp') || (die "Can't open temp file."); +open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; @@ -45,4 +43,17 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -unlink 'Io.argv.tmp'; +open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = 'Io.argv.tmp'; +$^I = '.bak'; +$/ = undef; +while (<>) { + s/^/ok 6\n/; + print; +} +open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +print while <try>; +close try; + +END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } diff --git a/t/io/dup.t b/t/io/dup.t index f312671e56..9ad823fff7 100755 --- a/t/io/dup.t +++ b/t/io/dup.t @@ -2,7 +2,7 @@ # $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $ -print "1..6\n"; +print "1..7\n"; print "ok 1\n"; @@ -37,3 +37,17 @@ else { system 'cat Io.dup' } unlink 'Io.dup'; print STDOUT "ok 6\n"; + +# 7 # 19990811 mjd@plover.com +my ($out1, $out2) = ("Line 1\n", "Line 2\n"); +open(W, "> Io.dup") || die "Can't open stdout"; +print W $out1, $out2; +close W; +open(R1, "< Io.dup") || die "Can't read temp file"; +$in1 = <R1>; +open(R2, "<&R1") || die "Can't dup"; +$in2 = <R2>; +print "not " unless $in1 eq $out1 && $in2 eq $out2; +print "ok 7\n"; + +unlink("Io.dup"); @@ -4,63 +4,83 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; -$Is_Dos=$^O eq 'dos'; +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); -# avoid win32 (for now) -do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; - -print "1..26\n"; +print "1..28\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -if ($^O eq 'MSWin32') { `del tmp`; `mkdir tmp`; } +if ($^O eq 'MSWin32') { `del 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'; umask(022); -if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +if ($^O eq 'MSWin32') { print "ok 1 # skipped: bogus umask()\n"; } +elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} open(fh,'>x') || die "Can't create x"; close(fh); open(fh,'>a') || die "Can't create a"; close(fh); -if (eval {link('a','b')} || $Is_Dos) {print "ok 2\n";} else {print "not ok 2\n";} +if ($Is_Dosish) {print "ok 2 # skipped: no link\n";} +elsif (eval {link('a','b')}) {print "ok 2\n";} +else {print "not ok 2\n";} -if (eval {link('b','c')} || $Is_Dos) {print "ok 3\n";} else {print "not ok 3\n";} +if ($Is_Dosish) {print "ok 3 # skipped: no link\n";} +elsif (eval {link('b','c')}) {print "ok 3\n";} +else {print "not ok 3\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); -if ($Config{dont_use_nlink} || $nlink == 3 || $Is_Dos) - {print "ok 4\n";} else {print "not ok 4\n";} +if ($Config{dont_use_nlink} || $Is_Dosish) + {print "ok 4 # skipped: no link\n";} +elsif ($nlink == 3) + {print "ok 4\n";} +else {print "not ok 4\n";} -if (($mode & 0777) == 0666 || $^O eq 'amigaos' || $Is_Dos) - {print "ok 5\n";} else {print "not ok 5\n";} +if ($^O eq 'amigaos' || $Is_Dosish) + {print "ok 5 # skipped: no link\n";} +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";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); -if (($mode & 0777) == 0777 || $Is_Dos) {print "ok 7\n";} else {print "not ok 7\n";} +if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} +elsif (($mode & 0777) == 0777) {print "ok 7\n";} +else {print "not ok 7\n";} -if ((chmod 0700,'c','x') == 2 || $Is_Dos) {print "ok 8\n";} else {print "not ok 8\n";} +if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} +elsif ((chmod 0700,'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 (($mode & 0777) == 0700 || $Is_Dos) {print "ok 9\n";} else {print "not ok 9\n";} +if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {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 (($mode & 0777) == 0700 || $Is_Dos) {print "ok 10\n";} else {print "not ok 10\n";} +if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {print "ok 10\n";} +else {print "not ok 10\n";} -if ((unlink 'b','x') == 2 || $Is_Dos) {print "ok 11\n";} else {print "not ok 11\n";} +if ($Is_Dosish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; } +elsif ((unlink 'b','x') == 2) {print "ok 11\n";} +else {print "not ok 11\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";} @@ -72,13 +92,16 @@ if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('a'); if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} -$foo = (utime 500000000,500000001,'b'); +$delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem +$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, $blksize,$blocks) = stat('b'); -if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} -if (($atime == 500000000 && $mtime == 500000001) - || $wd =~ m#/afs/# || $^O eq 'amigaos' || $Is_Dos) +if ($^O eq 'MSWin32') { print "ok 17 # skipped: bogus (stat)[1]\n"; } +elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";} +if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32') + {print "ok 18 # skipped: granularity of the filetime\n";} +elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";} @@ -90,7 +113,6 @@ if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} unlink 'c'; chdir $wd || die "Can't cd back to $wd"; -rmdir 'tmp'; unlink 'c'; if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { @@ -120,17 +142,27 @@ else { 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"; { select FH; $| = 1; select STDOUT } - print FH "helloworld\n"; - truncate FH, 5; - if ($Is_Dos) { + { + use strict; + print FH "helloworld\n"; + truncate FH, 5; + } + if ($^O eq 'dos') { 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"} truncate FH, 0; - if ($Is_Dos) { + if ($^O eq 'dos') { 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; } -unlink "Iofs.tmp"; + +# 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"; + +END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/t/io/open.t b/t/io/open.t new file mode 100755 index 0000000000..12d32f474c --- /dev/null +++ b/t/io/open.t @@ -0,0 +1,111 @@ +#!./perl + +# $RCSfile$ +$| = 1; +$^W = 1; + +print "1..32\n"; + +# my $file tests + +{ +unlink("afile") if -f "afile"; +print "$!\nnot " unless open(my $f,"+>afile"); +print "ok 1\n"; +binmode $f; +print "not " unless -f "afile"; +print "ok 2\n"; +print "not " unless print $f "SomeData\n"; +print "ok 3\n"; +print "not " unless tell($f) == 9; +print "ok 4\n"; +print "not " unless seek($f,0,0); +print "ok 5\n"; +$b = <$f>; +print "not " unless $b eq "SomeData\n"; +print "ok 6\n"; +print "not " unless -f $f; +print "ok 7\n"; +eval { die "Message" }; +# warn $@; +print "not " unless $@ =~ /<\$f> line 1/; +print "ok 8\n"; +print "not " unless close($f); +print "ok 9\n"; +unlink("afile"); +} +{ +print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); +print "ok 10\n"; +print $f "a row\n"; +print "not " unless close($f); +print "ok 11\n"; +print "not " unless -s 'afile' < 10; +print "ok 12\n"; +} +{ +print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); +print "ok 13\n"; +print $f "a row\n"; +print "not " unless close($f); +print "ok 14\n"; +print "not " unless -s 'afile' > 10; +print "ok 15\n"; +} +{ +print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); +print "ok 16\n"; +@rows = <$f>; +print "not " unless @rows == 2; +print "ok 17\n"; +print "not " unless close($f); +print "ok 18\n"; +} +{ +print "not " unless -s 'afile' < 20; +print "ok 19\n"; +print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); +print "ok 20\n"; +@rows = <$f>; +print "not " unless @rows == 2; +print "ok 21\n"; +seek $f, 0, 1; +print $f "yet another row\n"; +print "not " unless close($f); +print "ok 22\n"; +print "not " unless -s 'afile' > 20; +print "ok 23\n"; + +unlink("afile"); +} +{ +print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); +./perl -e "print qq(a row\n); print qq(another row\n)" +EOC +print "ok 24\n"; +@rows = <$f>; +print "not " unless @rows == 2; +print "ok 25\n"; +print "not " unless close($f); +print "ok 26\n"; +} +{ +print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); +./perl -pe "s/^not //" +EOC +print "ok 27\n"; +@rows = <$f>; +print $f "not ok 28\n"; +print $f "not ok 29\n"; +print "#\nnot " unless close($f); +sleep 1; +print "ok 30\n"; +} + +eval <<'EOE' and print "not "; +open my $f, '<&', 'afile'; +1; +EOE +print "ok 31\n"; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +print "ok 32\n"; diff --git a/t/io/openpid.t b/t/io/openpid.t new file mode 100755 index 0000000000..0e8b934e51 --- /dev/null +++ b/t/io/openpid.t @@ -0,0 +1,85 @@ +#!./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 = "$^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 "# 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/t/io/pipe.t b/t/io/pipe.t index ba7a9b093b..826cf7434a 100755 --- a/t/io/pipe.t +++ b/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,19 +80,20 @@ 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'; @@ -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; @@ -116,7 +133,6 @@ else { } # 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 }; @@ -133,3 +149,23 @@ if ($? == 37*256 && $wait == $zombie && ! $!) { } 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/t/io/tell.t b/t/io/tell.t index 83904e88bb..31287e1d19 100755 --- a/t/io/tell.t +++ b/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'); + 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/t/lib/abbrev.t b/t/lib/abbrev.t index fb5a9841eb..05e5c70cac 100755 --- a/t/lib/abbrev.t +++ b/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/t/lib/anydbm.t b/t/lib/anydbm.t index 0391b7b490..9efe5e9f3e 100755 --- a/t/lib/anydbm.t +++ b/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 { + print "not ok 12\n" ; + 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" ; + + print STDERR <<EOM ; +# +# 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. +# +EOM + } +} untie %h; if ($^O eq 'VMS') { diff --git a/t/lib/attrs.t b/t/lib/attrs.t new file mode 100644 index 0000000000..d8afbf635a --- /dev/null +++ b/t/lib/attrs.t @@ -0,0 +1,125 @@ +#!./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} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; diff --git a/t/lib/autoloader.t b/t/lib/autoloader.t index b1622a8ae2..3bf690bbdd 100755 --- a/t/lib/autoloader.t +++ b/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/t/lib/basename.t b/t/lib/basename.t index a02aa32cb7..478e26a8a5 100755 --- a/t/lib/basename.t +++ b/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/t/lib/bigfloat.t b/t/lib/bigfloat.t new file mode 100755 index 0000000000..8e0a0ef724 --- /dev/null +++ b/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/t/lib/bigfloatpm.t b/t/lib/bigfloatpm.t new file mode 100755 index 0000000000..42cd9583d1 --- /dev/null +++ b/t/lib/bigfloatpm.t @@ -0,0 +1,459 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::BigFloat; + +$test = 0; +$| = 1; +print "1..358\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\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'zero' ++2.23:-1:2.2 +-2.23:-1:-2.2 ++2.27:-1:2.3 +-2.27:-1:-2.3 ++2.25:-1:2.2 +-2.25:-1:-2.2 ++2.35:-1:2.3 +-2.35:-1:-2.3 +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-6\.5e-03 +$Math::BigFloat::rnd_mode = '+inf' ++3.23:-1:3.2 +-3.23:-1:-3.2 ++3.27:-1:3.3 +-3.27:-1:-3.3 ++3.25:-1:3.3 +-3.25:-1:-3.2 ++3.35:-1:3.4 +-3.35:-1:-3.3 +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-6\.5e-03 +$Math::BigFloat::rnd_mode = '-inf' ++4.23:-1:4.2 +-4.23:-1:-4.2 ++4.27:-1:4.3 +-4.27:-1:-4.3 ++4.25:-1:4.2 +-4.25:-1:-4.3 ++4.35:-1:4.3 +-4.35:-1:-4.4 +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'odd' ++5.23:-1:5.2 +-5.23:-1:-5.2 ++5.27:-1:5.3 +-5.27:-1:-5.3 ++5.25:-1:5.3 +-5.25:-1:-5.3 ++5.35:-1:5.3 +-5.35:-1:-5.3 +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'even' ++6.23:-1:6.2 +-6.23:-1:-6.2 ++6.27:-1:6.3 +-6.27:-1:-6.3 ++6.25:-1:6.2 +-6.25:-1:-6.2 ++6.35:-1:6.4 +-6.35:-1:-6.4 +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.0065|-6\.5e-03 +-0.0065:-5:/-0\.0065|-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 ++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/t/lib/bigint.t b/t/lib/bigint.t index 034c5c6457..d2d520ea3c 100755 --- a/t/lib/bigint.t +++ b/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } require "bigint.pl"; $test = 0; diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t index ebaecac21a..ae362e20c9 100755 --- a/t/lib/bigintpm.t +++ b/t/lib/bigintpm.t @@ -2,15 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -use Config; use Math::BigInt; $test = 0; $| = 1; -print "1..246\n"; +print "1..278\n"; while (<DATA>) { chop; if (s/^&//) { @@ -28,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"; @@ -53,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 @@ -94,28 +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 &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/t/lib/cgi-form.t b/t/lib/cgi-form.t index 86df161b02..e3cba5fc20 100755 --- a/t/lib/cgi-form.t +++ b/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/t/lib/cgi-function.t b/t/lib/cgi-function.t index ad8b968161..b4cd56811f 100755 --- a/t/lib/cgi-function.t +++ b/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/t/lib/cgi-html.t b/t/lib/cgi-html.t index d7f3ffb4aa..e878b21e50 100755 --- a/t/lib/cgi-html.t +++ b/t/lib/cgi-html.t @@ -5,18 +5,20 @@ 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..17\n"; } -BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";} +BEGIN {$| = 1; print "1..20\n"; } END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); +use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; print "ok 1\n"; ######################### End of black magic. +my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; + # util sub test { local($^W) = 0; @@ -37,10 +39,17 @@ 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()"); +if (!$Is_EBCDIC) { +test(9,header() eq "Content-Type: text/html\015\012\015\012","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif\015\012\015\012","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks\015\012Content-Type: image/gif\015\012\015\012","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK\015\012Content-Type: text/html\015\012\015\012","header()"); +} else { +test(9,header() eq "Content-Type: text/html\r\n\r\n","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif\r\n\r\n","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks\r\nContent-Type: image/gif\r\n\r\n","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK\r\nContent-Type: text/html\r\n\r\n","header()"); +} test(13,start_html() ."\n" eq <<END,"start_html()"); <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> <HTML><HEAD><TITLE>Untitled Document</TITLE> @@ -60,6 +69,14 @@ test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); 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, + 'fred=chocolate&chip; domain=localhost; path=/',"cookie()"); +if (!$Is_EBCDIC) { +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; domain=localhost; path=/\015\012Date:.*\015\012Content-Type: text/html\015\012\015\012!s, "header(-cookie)"); +} else { +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; domain=localhost; path=/\r\nDate:.*\r\nContent-Type: text/html\r\n\r\n!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/t/lib/cgi-request.t b/t/lib/cgi-request.t index 8c70c40350..9e8cdc290a 100755 --- a/t/lib/cgi-request.t +++ b/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/t/lib/charnames.t b/t/lib/charnames.t new file mode 100644 index 0000000000..8d5c8db384 --- /dev/null +++ b/t/lib/charnames.t @@ -0,0 +1,53 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +$| = 1; +print "1..5\n"; + +use charnames ':full'; + +print "not " unless "Here\N{EXCLAMATION MARK}?" eq 'Here!?'; +print "ok 1\n"; + +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'; + use utf8; + + 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"; +} diff --git a/t/lib/checktree.t b/t/lib/checktree.t index b5426ca261..760357529b 100755 --- a/t/lib/checktree.t +++ b/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/t/lib/complex.t b/t/lib/complex.t index 2bb14f0866..6fbdf8dd67 100755 --- a/t/lib/complex.t +++ b/t/lib/complex.t @@ -9,12 +9,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::Complex; -$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/); +my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -173,20 +173,6 @@ test_loz( 'acoth(-1)', ); -# test the 0**0 - -sub test_ztz { - $test++; - - push(@script, <<'EOT'); -eval 'cplx(0)**cplx(0)'; -print 'not ' unless ($@ =~ /zero raised to the zeroth/); -EOT - push(@script, qq(print "ok $test\\n";\n)); -} - -test_ztz; - # test the bad roots sub test_broot { @@ -387,6 +373,7 @@ __END__ (1,0):(2,3):(1,0) (2,3):(0,0):(1,0) (2,3):(1,0):(2,3) +(0,0):(0,0):(1,0) &Re (3,4):3 @@ -876,4 +863,3 @@ __END__ ( 2,-3):( 0.14694666622553, 0.23182380450040) # eof - diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index bf739c81d5..cea8163a46 100755 --- a/t/lib/db-btree.t +++ b/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,51 @@ 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) ; +} + + +my $Dfile = "dbbtree.tmp"; unlink $Dfile; umask(0); @@ -134,7 +178,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 +652,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 ($DB_File::db_version == 1 ? <<'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 ($DB_File::db_version == 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/t/lib/db-hash.t b/t/lib/db-hash.t index e748472263..c52d8ae9dd 100755 --- a/t/lib/db-hash.t +++ b/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/t/lib/db-recno.t b/t/lib/db-recno.t index c89c3cafde..276f38bc3a 100755 --- a/t/lib/db-recno.t +++ b/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,23 +38,68 @@ 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++ ; # -# Some older versions of Berkeley DB will fail tests 51, 53 and 55. +# Some older versions of Berkeley DB version 1 will fail tests 51, +# 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). # Otherwise you'll have to upgrade your DB library. # -# If you want to upgrade Berkeley DB, the most recent version is 1.85. -# Check out http://www.bostic.com/db for more details. +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. # EOM } -print "1..78\n"; +print "1..126\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -207,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 @@ -450,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/t/lib/dirhand.t b/t/lib/dirhand.t index aa7be356df..a8683c7fb8 100755 --- a/t/lib/dirhand.t +++ b/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/t/lib/dosglob.t b/t/lib/dosglob.t index 577d4eac22..ea537bf6d1 100755 --- a/t/lib/dosglob.t +++ b/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/t/lib/dprof.t b/t/lib/dprof.t new file mode 100755 index 0000000000..4d6f7823c3 --- /dev/null +++ b/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/t/lib/dprof/V.pm b/t/lib/dprof/V.pm new file mode 100644 index 0000000000..7e34da5d47 --- /dev/null +++ b/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/t/lib/dprof/test1_t b/t/lib/dprof/test1_t new file mode 100644 index 0000000000..d504cd5536 --- /dev/null +++ b/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/t/lib/dprof/test1_v b/t/lib/dprof/test1_v new file mode 100644 index 0000000000..542a503414 --- /dev/null +++ b/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/t/lib/dprof/test2_t b/t/lib/dprof/test2_t new file mode 100644 index 0000000000..edc46c527e --- /dev/null +++ b/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/t/lib/dprof/test2_v b/t/lib/dprof/test2_v new file mode 100644 index 0000000000..8b775b3131 --- /dev/null +++ b/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/t/lib/dprof/test3_t b/t/lib/dprof/test3_t new file mode 100644 index 0000000000..a5327f4d7a --- /dev/null +++ b/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/t/lib/dprof/test3_v b/t/lib/dprof/test3_v new file mode 100644 index 0000000000..df7543e2b8 --- /dev/null +++ b/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/t/lib/dprof/test4_t b/t/lib/dprof/test4_t new file mode 100644 index 0000000000..729968270a --- /dev/null +++ b/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/t/lib/dprof/test4_v b/t/lib/dprof/test4_v new file mode 100644 index 0000000000..d9677ff785 --- /dev/null +++ b/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/t/lib/dprof/test5_t b/t/lib/dprof/test5_t new file mode 100644 index 0000000000..0b1113757f --- /dev/null +++ b/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/t/lib/dprof/test5_v b/t/lib/dprof/test5_v new file mode 100644 index 0000000000..9e9298c689 --- /dev/null +++ b/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/t/lib/dprof/test6_t b/t/lib/dprof/test6_t new file mode 100644 index 0000000000..7b8bf4a722 --- /dev/null +++ b/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/t/lib/dprof/test6_v b/t/lib/dprof/test6_v new file mode 100644 index 0000000000..2f651ea794 --- /dev/null +++ b/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/t/lib/dumper-ovl.t b/t/lib/dumper-ovl.t index db4a5d9e75..8c095e59be 100755 --- a/t/lib/dumper-ovl.t +++ b/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/t/lib/dumper.t b/t/lib/dumper.t index 70f8abeb9e..9130d1c690 100755 --- a/t/lib/dumper.t +++ b/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; @@ -20,6 +20,8 @@ sub TEST { my $string = shift; my $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); @@ -29,17 +31,19 @@ sub TEST { $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); 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 = 138; $XS = 1; + $TMAX = 174; $XS = 1; } else { print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 69; $XS = 0; + $TMAX = 87; $XS = 0; } print "1..$TMAX\n"; @@ -236,11 +240,11 @@ EOT ## $WANT = <<'EOT'; #$VAR1 = { -# "abc\000\efg" => "mno\000" +# "abc\0'\efg" => "mno\0" #}; EOT -$foo = { "abc\000\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000" }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -248,7 +252,7 @@ $foo = { "abc\000\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\000\efg' => 'mno\000' +# 'abc\0\\'\efg' => 'mno\0' #}; EOT @@ -450,8 +454,8 @@ EOT # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; @@ -489,8 +493,8 @@ EOT # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; @@ -566,8 +570,8 @@ EOT { -sub a { print "foo\n" } -$c = [ \&a ]; +sub z { print "foo\n" } +$c = [ \&z ]; ############# 121 ## @@ -578,8 +582,8 @@ $c = [ \&a ]; #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) if $XS; ############# 127 @@ -591,8 +595,8 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) if $XS; ############# 133 @@ -604,8 +608,146 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) #); EOT -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) if $XS; } + +{ + $a = []; + $a->[1] = \$a->[0]; + +############# 139 +## + $WANT = <<'EOT'; +#@a = ( +# undef, +# '' +#); +#$a[1] = \$a[0]; +EOT + +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = \\\\\'foo'; + $b = $$$a; + +############# 145 +## + $WANT = <<'EOT'; +#$a = \\\\\'foo'; +#$b = ${${$a}}; +EOT + +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +############# 151 +## + $WANT = <<'EOT'; +#$a = [ +# { +# a => \[ +# { +# c => '' +# }, +# { +# d => \[] +# } +# ] +# }, +# { +# b => undef +# } +#]; +#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; +#${${$a->[0]{a}}->[1]->{d}} = $a; +#$b = ${$a->[0]{a}}; +EOT + +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = [[[[\\\\\'foo']]]]; + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +############# 157 +## + $WANT = <<'EOT'; +#$a = [ +# [ +# [ +# [ +# \\\\\'foo' +# ] +# ] +# ] +#]; +#$b = $a->[0][0]; +#$c = ${${$a->[0][0][0][0]}}; +EOT + +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; +} diff --git a/t/lib/english.t b/t/lib/english.t index 9691229be0..2ee613352b 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -2,7 +2,7 @@ print "1..16\n"; -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } use English; use Config; my $threads = $Config{'usethreads'} || 0; diff --git a/t/lib/env.t b/t/lib/env.t index 5a8220778a..93d24066e6 100755 --- a/t/lib/env.t +++ b/t/lib/env.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } BEGIN { diff --git a/t/lib/errno.t b/t/lib/errno.t index 361723f1b2..6320f6b236 100755 --- a/t/lib/errno.t +++ b/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/t/lib/fatal.t b/t/lib/fatal.t new file mode 100755 index 0000000000..019265899a --- /dev/null +++ b/t/lib/fatal.t @@ -0,0 +1,28 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..13\n"; +} + +use strict; +use Fatal qw(open close); + +my $i = 1; +eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " unless $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; + +my $foo = 'FOO'; +for ('$foo', "'$foo'", "*$foo", "\\*$foo") { + eval qq{ open $_, '<$0' }; + print "not " if $@; + print "ok $i\n"; ++$i; + + 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; +} diff --git a/t/lib/fields.t b/t/lib/fields.t index 139e469b5a..6f3ea5bb48 100755 --- a/t/lib/fields.t +++ b/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++; @@ -82,7 +82,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)+5, "\n"; my $testno = 0; while (my($class, $exp) = each %expect) { no strict 'refs'; @@ -110,3 +110,17 @@ print "not " unless $@ && $@ =~ /^No such field "notthere"/; print "ok ", ++$testno, "\n"; #fields::_dump(); + +# check if +{ + 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"; +} diff --git a/t/lib/filecache.t b/t/lib/filecache.t index a97fdd532c..019f3742c5 100755 --- a/t/lib/filecache.t +++ b/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/t/lib/filecopy.t b/t/lib/filecopy.t index 329931f4b4..e461595d9b 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..11\n"; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index cd2e9771c7..5d1492f040 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..2\n"; diff --git a/t/lib/filefunc.t b/t/lib/filefunc.t new file mode 100755 index 0000000000..46a1e35774 --- /dev/null +++ b/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/t/lib/filehand.t b/t/lib/filehand.t index 08cae71872..22cff0ecb0 100755 --- a/t/lib/filehand.t +++ b/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"; @@ -31,7 +31,7 @@ $buffer = <$fh>; print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; -ungetc $fh 65; +ungetc $fh ord 'A'; CORE::read($fh, $buf,1); print $buf eq 'A' ? "ok 4\n" : "not ok 4\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/t/lib/filepath.t b/t/lib/filepath.t index c3bf4a4479..40e6e213c1 100755 --- a/t/lib/filepath.t +++ b/t/lib/filepath.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use File::Path; diff --git a/t/lib/filespec.t b/t/lib/filespec.t index ca22d3e12b..3aeed17958 100755 --- a/t/lib/filespec.t +++ b/t/lib/filespec.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..4\n"; diff --git a/t/lib/findbin.t b/t/lib/findbin.t index 3e742f9a4f..f0939e94a9 100755 --- a/t/lib/findbin.t +++ b/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/t/lib/gdbm.t b/t/lib/gdbm.t index 2395611d1e..dc4e96e4d8 100755 --- a/t/lib/gdbm.t +++ b/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/t/lib/getopt.t b/t/lib/getopt.t index fb70f10aae..035462722b 100755 --- a/t/lib/getopt.t +++ b/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/t/lib/gol-basic.t b/t/lib/gol-basic.t new file mode 100755 index 0000000000..4b25322336 --- /dev/null +++ b/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/t/lib/gol-compat.t b/t/lib/gol-compat.t new file mode 100755 index 0000000000..a4f807c7dd --- /dev/null +++ b/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/t/lib/gol-linkage.t b/t/lib/gol-linkage.t new file mode 100755 index 0000000000..a1b2c05be3 --- /dev/null +++ b/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/t/lib/h2ph.pht b/t/lib/h2ph.pht index 80867a6113..e5b293243e 100644 --- a/t/lib/h2ph.pht +++ b/t/lib/h2ph.pht @@ -1,3 +1,5 @@ +require '_h2ph_pre.ph'; + unless(defined(&SQUARE)) { sub SQUARE { local($x) = @_; @@ -27,7 +29,7 @@ unless(defined(&_H2PH_H_)) { if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) { } elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) { - die("Nup, can't go on "); + die("Nup\,\ can\'t\ go\ on\ "); } else { eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); } diff --git a/t/lib/h2ph.t b/t/lib/h2ph.t index 1fa7f63536..acb150dfcd 100755 --- a/t/lib/h2ph.t +++ b/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/t/lib/hostname.t b/t/lib/hostname.t index e4ac36521c..30dcf0f0b7 100755 --- a/t/lib/hostname.t +++ b/t/lib/hostname.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Sys::Hostname; diff --git a/t/lib/io_const.t b/t/lib/io_const.t new file mode 100755 index 0000000000..48cb6b5dc8 --- /dev/null +++ b/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/t/lib/io_dir.t b/t/lib/io_dir.t new file mode 100755 index 0000000000..11ec8bcbf9 --- /dev/null +++ b/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/t/lib/io_dup.t b/t/lib/io_dup.t index 6b0caf14fa..c895fb4c25 100755 --- a/t/lib/io_dup.t +++ b/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/t/lib/io_linenum.t b/t/lib/io_linenum.t new file mode 100755 index 0000000000..3503215201 --- /dev/null +++ b/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/t/lib/io_multihomed.t b/t/lib/io_multihomed.t new file mode 100644 index 0000000000..7337a5f8d6 --- /dev/null +++ b/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/t/lib/io_pipe.t b/t/lib/io_pipe.t index e1c48b6a7e..bcb89a0daf 100755 --- a/t/lib/io_pipe.t +++ b/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; } } @@ -41,6 +47,13 @@ print $pipe "not ok 3\n" ; $pipe->close or print "# \$!=$!\nnot "; print "ok 4\n"; +# Check if can fork with dynamic extensions (bug in CRT): +if ($^O eq 'os2' and + system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { + print "ok $_ # skipped: broken fork\n" for 5..10; + exit 0; +} + $pipe = new IO::Pipe; $pid = fork(); diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t new file mode 100755 index 0000000000..c179ce96fb --- /dev/null +++ b/t/lib/io_poll.t @@ -0,0 +1,72 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +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/t/lib/io_sel.t b/t/lib/io_sel.t index 3dc651bbc2..e0d7a45338 100755 --- a/t/lib/io_sel.t +++ b/t/lib/io_sel.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/t/lib/io_sock.t b/t/lib/io_sock.t index 9fab56b237..782f2554c8 100755 --- a/t/lib/io_sock.t +++ b/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,32 +11,50 @@ 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"; +# Check if can fork with dynamic extensions (bug in CRT): +if ($^O eq 'os2' and + system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { + print "ok $_ # skipped: broken fork\n" for 2..5; + exit 0; +} + $port = $listen->sockport; if($pid = fork()) { - $sock = $listen->accept(); + $sock = $listen->accept() or die "accept failed: $!"; print "ok 2\n"; $sock->autoflush(1); @@ -62,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); @@ -77,8 +95,99 @@ 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 ($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/t/lib/io_taint.t b/t/lib/io_taint.t index 0ef2cfd63f..deaa6c7f61 100755 --- a/t/lib/io_taint.t +++ b/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/t/lib/io_tell.t b/t/lib/io_tell.t index 2009d610db..8d75242251 100755 --- a/t/lib/io_tell.t +++ b/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/t/lib/io_udp.t b/t/lib/io_udp.t index 014e12dc58..3d5145ec5e 100755 --- a/t/lib/io_udp.t +++ b/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 '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/t/lib/io_unix.t b/t/lib/io_unix.t new file mode 100644 index 0000000000..7338861fb4 --- /dev/null +++ b/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') { + use 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/t/lib/io_xs.t b/t/lib/io_xs.t index 1a6fd381a3..6bbba16f8c 100755 --- a/t/lib/io_xs.t +++ b/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/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t index f74c5fa060..00a157ba54 100755 --- a/t/lib/ipc_sysv.t +++ b/t/lib/ipc_sysv.t @@ -3,14 +3,20 @@ 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; } } @@ -18,7 +24,7 @@ BEGIN { # 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); + S_IRWXU S_IRWXG S_IRWXO S_IWGRP S_IROTH S_IWOTH); use strict; print "1..16\n"; @@ -28,11 +34,40 @@ my $sem; $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed +# FreeBSD is known to throw this if there's no SysV IPC in the kernel. +$SIG{SYS} = sub { + print STDERR <<EOM; +SIGSYS caught. +It may be that your kernel does not have SysV IPC configured. + +EOM + if ($^O eq 'freebsd') { + print STDERR <<EOM; +You must have following options in your kernel: + +options SYSVSHM +options SYSVSEM +options SYSVMSG + +See config(8). +EOM + } + exit(1); +}; + +my $perm; + +$perm = S_IRWXU | S_IRWXG | S_IRWXO | S_IWGRP | S_IROTH | S_IWOTH + if $^O eq 'vmesa'; + +$perm = S_IRWXU | S_IRWXG | S_IRWXO unless defined $perm; + 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; @@ -69,80 +104,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); - - $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; + if ($Config{'d_semctl_semid_ds'} eq 'define' || + $Config{'d_semctl_semun'} eq 'define') { - print "ok 7\n"; - - my $data; - semctl($sem,0,IPC_STAT,$data) or print "not "; - print "ok 8\n"; + use IPC::SysV qw(IPC_CREAT GETALL SETALL); - 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; - } - } - } + $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; - die "$0: cannot pack native shorts\n" unless defined $template; + print "ok 7\n"; - $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/t/lib/ndbm.t b/t/lib/ndbm.t index a97dbd1f1e..39c3f400a0 100755 --- a/t/lib/ndbm.t +++ b/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/t/lib/odbm.t b/t/lib/odbm.t index 8ba9bcf3a4..f8b8a110ad 100755 --- a/t/lib/odbm.t +++ b/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/t/lib/opcode.t b/t/lib/opcode.t index a785fce48b..f83a689f05 100755 --- a/t/lib/opcode.t +++ b/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/t/lib/open2.t b/t/lib/open2.t index 85b807c98a..64431123e8 100755 --- a/t/lib/open2.t +++ b/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/t/lib/open3.t b/t/lib/open3.t index b84dac9f14..7cd0ca306c 100755 --- a/t/lib/open3.t +++ b/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/t/lib/ops.t b/t/lib/ops.t index 56b1bacabb..ce8b6d0d5f 100755 --- a/t/lib/ops.t +++ b/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/t/lib/parsewords.t b/t/lib/parsewords.t index 90791790ab..86323b6fc6 100755 --- a/t/lib/parsewords.t +++ b/t/lib/parsewords.t @@ -2,12 +2,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Text::ParseWords; -print "1..17\n"; +print "1..18\n"; @words = shellwords(qq(foo "bar quiz" zoo)); print "not " if $words[0] ne 'foo'; @@ -101,3 +101,8 @@ $string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; $result = join('|', parse_line('\s+', 0, $string)); print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; print "ok 17\n"; + +# test whitespace in the delimiters +@words = quotewords(' ', 1, '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4;3;2;1;0); +print "ok 18\n"; diff --git a/t/lib/ph.t b/t/lib/ph.t index d0a48f6c51..dd24c79f2d 100755 --- a/t/lib/ph.t +++ b/t/lib/ph.t @@ -6,11 +6,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -use Config; - # All the constants which Socket.pm tries to make available: my @possibly_defined = qw( INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT diff --git a/t/lib/posix.t b/t/lib/posix.t index c071c3b067..4c6aa49a05 100755 --- a/t/lib/posix.t +++ b/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"; @@ -96,5 +96,6 @@ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); $| = 0; -print '@#!*$@(!@#$'; +# The following line assumes buffered output, which may be not true with EMX: +print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); _exit(0); diff --git a/t/lib/safe1.t b/t/lib/safe1.t index 27993d95c9..6e12873585 100755 --- a/t/lib/safe1.t +++ b/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/t/lib/safe2.t b/t/lib/safe2.t index c9e38808b3..572876c5ca 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -2,14 +2,15 @@ $|=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"; exit 0; } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; + # test 30 rather naughtily expects English error messages + $ENV{'LC_ALL'} = 'C'; + $ENV{LANGUAGE} = 'C'; # GNU locale extension } # Tests Todo: @@ -122,11 +123,9 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); -print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || - $! =~ /A file or directory in the path name does not exist/ || - $! =~ /Invalid argument/ || - $! =~ /Device not configured/ ? - "ok $t\n" : "not ok $t # $!\n"); $t++; +# 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++; +# test #31 is gone. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; #my $rdo_file = "tmp_rdo.tpl"; diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index 591fe14c60..2689d1962e 100755 --- a/t/lib/sdbm.t +++ b/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/t/lib/searchdict.t b/t/lib/searchdict.t index 447c425b27..46cea394bc 100755 --- a/t/lib/searchdict.t +++ b/t/lib/searchdict.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..3\n"; +print "1..4\n"; $DICT = <<EOT; Aarhus @@ -44,22 +44,44 @@ open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; binmode DICT; # To make length expected one. print DICT $DICT; -my $pos = look *DICT, "abash"; +my $pos = look *DICT, "Ababa"; chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "abash"; +print "not " if $pos < 0 || $word ne "Ababa"; print "ok 1\n"; -$pos = look *DICT, "foo"; -chomp($word = <DICT>); +if (ord('a') > ord('A') ) { # ASCII + + $pos = look *DICT, "foo"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; -print "not " if $pos != length($DICT); # will search to end of file -print "ok 2\n"; + my $pos = look *DICT, "abash"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "abash"; + print "ok 3\n"; + +} +else { # EBCDIC systems e.g. os390 + + $pos = look *DICT, "FOO"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; + + my $pos = look *DICT, "Abba"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "Abba"; + print "ok 3\n"; +} $pos = look *DICT, "aarhus", 1, 1; chomp($word = <DICT>); print "not " if $pos < 0 || $word ne "Aarhus"; -print "ok 3\n"; +print "ok 4\n"; close DICT or die "cannot close"; unlink "dict-$$"; diff --git a/t/lib/selectsaver.t b/t/lib/selectsaver.t index 3b58d709ab..677caec894 100755 --- a/t/lib/selectsaver.t +++ b/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/t/lib/socket.t b/t/lib/socket.t index 4e382958ce..8f945ac6f7 100755 --- a/t/lib/socket.t +++ b/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})) { diff --git a/t/lib/soundex.t b/t/lib/soundex.t index d35f264c7a..a04cccd43c 100755 --- a/t/lib/soundex.t +++ b/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/t/lib/symbol.t b/t/lib/symbol.t index 03449a3ed7..14c919c0f3 100755 --- a/t/lib/symbol.t +++ b/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/t/lib/syslfs.t b/t/lib/syslfs.t new file mode 100644 index 0000000000..4d38a8e779 --- /dev/null +++ b/t/lib/syslfs.t @@ -0,0 +1,171 @@ +# NOTE: this file tests how large files (>2GB) work with raw system IO. +# open(), tell(), seek(), print(), read() are tested in t/op/lfs.t. +# If you modify/add tests here, remember to update also t/op/lfs.t. + +BEGIN { + # Don't bother if there are no quads. + 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'; + 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; +} + +sub bye { + close(BIG); + unlink "big"; + 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 is not +# allowed to write large files or that the file system you are running +# the tests on doesn't support large files, or both. You may also need +# to reconfigure your kernel. (This is all very system-dependent.) +# +# Perl may still be able to support large files, once you have +# such a process and such a (file) system. +# +EOM +} + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files\n"; + bye(); +} + +# Then try 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, "big", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen failed: $!\n"; bye }; +sysseek(BIG, 1_000_000, SEEK_SET); +syswrite(BIG, "big"); +close(BIG); + +my @s; + +@s = stat("big"); + +print "# @s\n"; + +my $BLOCKSIZE = 512; # is this really correct everywhere? + +unless (@s == 13 && + $s[7] == 1_000_003 && + defined $s[12] && + $BLOCKSIZE * $s[12] < 1_000_003) { + print "1..0\n# no sparse files?\n"; + bye(); +} + +# 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. + +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen failed: $!\n"; bye }; +sysseek(BIG, 5_000_000_000, SEEK_SET); +# The syswrite will fail if there are are filesize limitations (process or fs). +unless(syswrite(BIG, "big") == 3) { + $ENV{LC_ALL} = "C"; + if ($! =~/File too large/) { + print "1..0\n# writing past 2GB failed\n"; + explain(); + bye(); + } +} +close BIG; + +@s = stat("big"); + +print "# @s\n"; + +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 + +# eof diff --git a/t/lib/textfill.t b/t/lib/textfill.t new file mode 100755 index 0000000000..daeee2367c --- /dev/null +++ b/t/lib/textfill.t @@ -0,0 +1,98 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Text::Wrap qw(&fill); + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +Cyberdog Information + +Cyberdog & Netscape in the news +Important Press Release regarding Cyberdog and Netscape. Check it out! + +Cyberdog Plug-in Support! +Cyberdog support for Netscape Plug-ins is now available to download! Go +to the Cyberdog Beta Download page and download it now! + +Cyberdog Book +Check out Jesse Feiler's way-cool book about Cyberdog. You can find +details out about the book as well as ordering information at Philmont +Software Mill site. + +Java! +Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install +the Mac OS Runtime for Java and try it out! + +Cyberdog 1.1 Beta 3 +We hope that Cyberdog and OpenDoc 1.1 will be available within the next +two weeks. In the meantime, we have released another version of +Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were +reported to us during out public beta period. You can check out our release +notes to see what we fixed! +END + Cyberdog Information + Cyberdog & Netscape in the news Important Press Release regarding + Cyberdog and Netscape. Check it out! + Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now + available to download! Go to the Cyberdog Beta Download page and download + it now! + Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. + You can find details out about the book as well as ordering information at + Philmont Software Mill site. + Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and + install the Mac OS Runtime for Java and try it out! + Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be + available within the next two weeks. In the meantime, we have released + another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes + several bugs that were reported to us during out public beta period. You + can check out our release notes to see what we fixed! +END +DONE + + +$| = 1; + +print "1..", @tests/2, "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = fill(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + open(F,">#o") and do { print F $back; close(F) }; + open(F,">#e") and do { print F $out; close(F) }; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + fill(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/t/lib/texttabs.t b/t/lib/texttabs.t index ea9012c652..80395f4c02 100755 --- a/t/lib/texttabs.t +++ b/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/t/lib/textwrap.t b/t/lib/textwrap.t index 9c8d1b4975..bb1d5ca4a5 100755 --- a/t/lib/textwrap.t +++ b/t/lib/textwrap.t @@ -1,40 +1,129 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use Text::Wrap qw(&wrap); -print "1..5\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +This +is +a +test +END + This + is + a + test +END +TEST2 +This is a test of a very long line. It should be broken up and put onto multiple lines. +This is a test of a very long line. It should be broken up and put onto multiple lines. -use Text::Wrap qw(wrap $columns); +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + This is a test of a very long line. It should be broken up and put onto + multiple lines. + + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST3 +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST4 +This is a test of a very long line. It should be broken up and put onto multiple lines. -$columns = 30; +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. -$text = <<'EOT'; -Text::Wrap is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. -Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. -EOT +END +TEST5 +This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put +END + This is a test of a very long line. It should be broken up and put onto + multiple This is a test of a very long line. It should be broken up and + put +END +TEST6 +11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END + 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 + 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff + gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn + ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END +TEST7 +c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END + c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 + c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 + c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 + c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END +TEST8 +A test of a very very long word. +a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST9 +A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +DONE -$text =~ s/\n/ /g; -$_ = wrap "| ", "|", $text; -#print "$_\n"; +$| = 1; -print "not " unless /^\| Text::Wrap is/; # start is ok -print "ok 1\n"; +print "1..", @tests/2, "\n"; -print "not " if /^.{31,}$/m; # no line longer than 30 chars -print "ok 2\n"; +use Text::Wrap; -print "not " unless /^\|\w/m; # other lines start with -print "ok 3\n"; +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; -print "not " unless /\bsubsquent\b/; # look for a random word -print "ok 4\n"; +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); -print "not " unless /\bdevice\./; # look for last word -print "ok 5\n"; + $in =~ s/^TEST(\d+)?\n//; + + my $back = wrap(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/t/lib/thread.t b/t/lib/thread.t index 83407a9fab..3bca8ba726 100755 --- a/t/lib/thread.t +++ b/t/lib/thread.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (! $Config{'usethreads'}) { - print "1..0\n"; + print "1..0 # Skip: this perl is not threaded\n"; exit 0; } @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..14\n"; +print "1..18\n"; use Thread; print "ok 1\n"; @@ -24,7 +24,7 @@ sub content } # create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n"); +my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); print $t->join; # check that lock works ... @@ -71,3 +71,17 @@ sub islocked $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); $t->join->join; +{ + package Loch::Ness; + sub new { bless [], shift } + sub monster { + use attrs qw(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); diff --git a/t/lib/tie-push.t b/t/lib/tie-push.t index dd718deb14..23a0a9403a 100755 --- a/t/lib/tie-push.t +++ b/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/t/lib/tie-stdarray.t b/t/lib/tie-stdarray.t index 7ca4d76f11..5a678a5a1f 100755 --- a/t/lib/tie-stdarray.t +++ b/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/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t new file mode 100755 index 0000000000..cb8303d94d --- /dev/null +++ b/t/lib/tie-stdhandle.t @@ -0,0 +1,49 @@ +#!./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/t/lib/tie-stdpush.t b/t/lib/tie-stdpush.t index 34a69472f4..35ae1b89a4 100755 --- a/t/lib/tie-stdpush.t +++ b/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/t/lib/timelocal.t b/t/lib/timelocal.t index 100e0768aa..359d71e64c 100755 --- a/t/lib/timelocal.t +++ b/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/t/lib/trig.t b/t/lib/trig.t index 3114176ab0..20669f0bd9 100755 --- a/t/lib/trig.t +++ b/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/t/op/64bit.t b/t/op/64bit.t new file mode 100644 index 0000000000..09419f8790 --- /dev/null +++ b/t/op/64bit.t @@ -0,0 +1,182 @@ +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. +# +# Nota bene: bit operations (&, |, ^, ~, <<, >>) are not 64-bit clean. +# See the beginning of pp.c and the explanation next to IBW/UBW. + +# so that using > 0xfffffff constants and +# 32+ bit vector sizes doesn't cause noise +no warnings qw(overflow portable); + +print "1..34\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 six 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; +print "ok 27\n"; + +$a = 9223372036854775807; +$c = $a + 1; +print "not " unless $a == 9223372036854775808; +print "ok 28\n"; + +$a = -9223372036854775808; +$c = $a--; +print "not " unless $a == -9223372036854775809; +print "ok 29\n"; + +$a = -9223372036854775808; +$c = --$a; +print "not " unless $a == -9223372036854775809; +print "ok 30\n"; + +$a = -9223372036854775808; +$c = $a - 1; +print "not " unless $a == -9223372036854775809; +print "ok 31\n"; + + +$x = ''; +print "not " unless (vec($x, 1, 64) = $q) == $q; +print "ok 32\n"; + +print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f; +print "ok 33\n"; + +print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0; +print "ok 34\n"; + +# eof diff --git a/t/op/arith.t b/t/op/arith.t index 43af807b8b..f1bd827f9b 100755 --- a/t/op/arith.t +++ b/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,7 @@ try 1, 13 % 4 == 1; try 2, -13 % 4 == 3; try 3, 13 % -4 == -3; try 4, -13 % -4 == -1; +try 5, abs( 13e21 % 4e21 - 1e21) < 1e6; +try 6, abs(-13e21 % 4e21 - 3e21) < 1e6; +try 7, abs( 13e21 % -4e21 - -3e21) < 1e6; +try 8, abs(-13e21 % -4e21 - -1e21) < 1e6; diff --git a/t/op/array.t b/t/op/array.t index 8dea44de3f..3409556396 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..63\n"; +print "1..65\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -206,3 +206,8 @@ t("@bar" eq "foo bar"); # 43 t("@bee" eq "foo bar burbl blah"); # 63 } +# make sure reification behaves +my $t = 63; +sub reify { $_[1] = ++$t; print "@_\n"; } +reify('ok'); +reify('ok'); diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t index 57e89c45e0..00f7abbf67 100755 --- a/t/op/assignwarn.t +++ b/t/op/assignwarn.t @@ -8,7 +8,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; diff --git a/t/op/attrs.t b/t/op/attrs.t new file mode 100644 index 0000000000..e89c2cb816 --- /dev/null +++ b/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/t/op/auto.t b/t/op/auto.t index 93a42f8472..2eb0097650 100755 --- a/t/op/auto.t +++ b/t/op/auto.t @@ -2,7 +2,7 @@ # $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $ -print "1..34\n"; +print "1..37\n"; $x = 10000; if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";} @@ -46,3 +46,7 @@ if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";} if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";} if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";} if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";} +if (++($foo = 'A99') eq 'B00') {print "ok 35\n";} else {print "not ok 35\n";} +# EBCDIC guards: i and j, r and s, are not contiguous. +if (++($foo = 'zi') eq 'zj') {print "ok 36\n";} else {print "not ok 36\n";} +if (++($foo = 'zr') eq 'zs') {print "ok 37\n";} else {print "not ok 37\n";} diff --git a/t/op/avhv.t b/t/op/avhv.t index 55cc992e63..6837127d52 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } require Tie::Array; diff --git a/t/op/bop.t b/t/op/bop.t index 0c55029b93..0c5ef4874d 100755 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..18\n"; @@ -42,14 +42,23 @@ print ((($cusp >> 1) == ($cusp / 2) && do { use integer; $cusp >> 1 } == -($cusp / 2)) ? "ok 12\n" : "not ok 12\n"); +$Aaz = chr(ord("A") & ord("z")); +$Aoz = chr(ord("A") | ord("z")); +$Axz = chr(ord("A") ^ ord("z")); + # short strings -print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n"); -print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n"); -print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n"); +print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n"); # long strings $foo = "A" x 150; $bar = "z" x 75; -print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n"); -print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n"); -print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n"); +$zap = "A" x 75; +# & truncates +print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n"); +# | does not truncate +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"); + diff --git a/t/op/chars.t b/t/op/chars.t new file mode 100755 index 0000000000..efdea027bb --- /dev/null +++ b/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/t/op/chop.t b/t/op/chop.t index 77263ad3ad..6723ca3f1b 100755 --- a/t/op/chop.t +++ b/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/t/op/closure.t b/t/op/closure.t index 95d44f51e3..2284be6df1 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; diff --git a/t/op/defins.t b/t/op/defins.t index 0ed61ce2fb..9e714a718b 100755 --- a/t/op/defins.t +++ b/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"; } @@ -61,6 +61,7 @@ while ($where{$seen} = <FILE>) } print "not " unless $seen; print "ok 5\n"; +close FILE; opendir(DIR,'.'); $seen = 0; diff --git a/t/op/die.t b/t/op/die.t index d473ed6b7f..cf4f8b0555 100755 --- a/t/op/die.t +++ b/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/t/op/die_exit.t b/t/op/die_exit.t index b5760d6fa0..7808d9d7c5 100755 --- a/t/op/die_exit.t +++ b/t/op/die_exit.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -e '../lib'; + unshift @INC, '../lib' if -e '../lib'; } my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; @@ -30,6 +30,8 @@ my %tests = ( 14 => [ 255, 0], 15 => [ 255, 1], 16 => [ 255, 256], + # see if implicit close preserves $? + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], ); my $max = keys %tests; @@ -37,14 +39,15 @@ my $max = keys %tests; print "1..$max\n"; foreach my $test (1 .. $max) { - my($bang, $query) = @{$tests{$test}}; + my($bang, $query, $code) = @{$tests{$test}}; + $code ||= 'die;'; my $exit = ($^O eq 'MSWin32' - ? system qq($perl -e "\$! = $bang; \$? = $query; die;" 2> nul) - : system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null)); + ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul) + : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null)); - printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query - unless $exit == (($bang || ($query >> 8) || 255) << 8); + printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; + print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); print "ok $test\n"; } diff --git a/t/op/each.t b/t/op/each.t index 420fdc09c3..879c0d0fd3 100755 --- a/t/op/each.t +++ b/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'; @@ -43,7 +41,8 @@ if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";} $i = 0; # stop -w complaints while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + if ($key eq $keys[$i] && $value eq $values[$i] + && (('a' lt 'A' && $key lt $value) || $key gt $value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -119,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/t/op/eval.t b/t/op/eval.t index 9368281d5b..abcb3794b7 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $ - -print "1..23\n"; +print "1..37\n"; eval 'print "ok 1\n";'; @@ -79,3 +77,102 @@ eval { }; &$x(); } + +my $b = 'wrong'; +my $X = sub { + my $b = "right"; + print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n"; +}; +&$X(); + + +# check navigation of multiple eval boundaries to find lexicals + +my $x = 25; +eval <<'EOT'; die if $@; + print "# $x\n"; # clone into eval's pad + sub do_eval1 { + eval $_[0]; die if $@; + } +EOT +do_eval1('print "ok $x\n"'); +$x++; +do_eval1('eval q[print "ok $x\n"]'); +$x++; +do_eval1('sub { eval q[print "ok $x\n"] }->()'); +$x++; + +# calls from within eval'' should clone outer lexicals + +eval <<'EOT'; die if $@; + sub do_eval2 { + eval $_[0]; die if $@; + } +do_eval2('print "ok $x\n"'); +$x++; +do_eval2('eval q[print "ok $x\n"]'); +$x++; +do_eval2('sub { eval q[print "ok $x\n"] }->()'); +$x++; +EOT + +# calls outside eval'' should NOT clone lexicals from called context + +$main::x = 'ok'; +eval <<'EOT'; die if $@; + # $x unbound here + sub do_eval3 { + eval $_[0]; die if $@; + } +EOT +do_eval3('print "$x ' . $x . '\n"'); +$x++; +do_eval3('eval q[print "$x ' . $x . '\n"]'); +$x++; +do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()'); +$x++; + +# can recursive subroutine-call inside eval'' see its own lexicals? +sub recurse { + my $l = shift; + if ($l < $x) { + ++$l; + eval 'print "# level $l\n"; recurse($l);'; + die if $@; + } + else { + print "ok $l\n"; + } +} +{ + local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ }; + recurse($x-5); +} +$x++; + +# do closures created within eval bind correctly? +eval <<'EOT'; + sub create_closure { + my $self = shift; + return sub { + print $self; + }; + } +EOT +create_closure("ok $x\n")->(); +$x++; + +# does lexical search terminate correctly at subroutine boundary? +$main::r = "ok $x\n"; +sub terminal { eval 'print $r' } +{ + my $r = "not ok $x\n"; + eval 'terminal($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 $@; + diff --git a/t/op/exec.t b/t/op/exec.t index 506fc09fbd..5d014369ba 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -1,19 +1,24 @@ #!./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); } print "1..8\n"; -print "not ok 1\n" if system "echo ok \\1"; # shell interpreted +if ($^O ne 'os2') { + print "not ok 1\n" if system "echo ok \\1"; # shell interpreted +} +else { + print "ok 1 # skipped: bug/feature of pdksh\n"; # shell interpreted +} print "not ok 2\n" if system "echo ok 2"; # split and directly called print "not ok 3\n" if system "echo", "ok", "3"; # directly called @@ -23,7 +28,16 @@ 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 ((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/t/op/fh.t b/t/op/fh.t new file mode 100755 index 0000000000..86e405a992 --- /dev/null +++ b/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/t/op/filetest.t b/t/op/filetest.t new file mode 100755 index 0000000000..e00d5fb7b0 --- /dev/null +++ b/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/t/op/fork.t b/t/op/fork.t index 9790ff0f8c..20c87472b2 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -4,10 +4,10 @@ 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; } } diff --git a/t/op/goto.t b/t/op/goto.t index 1b34acda39..7a5de5fea5 100755 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $ - # "This IS structured code. It's just randomly structured." -print "1..9\n"; +print "1..16\n"; while ($?) { $foo = 1; @@ -56,7 +54,28 @@ sub bar { exit; FINALE: -print "ok 9\n"; +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: @@ -86,5 +105,22 @@ $wherever = NOWHERE; eval { goto $wherever }; print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n"; +# see if a modified @_ propagates +{ + package Foo; + sub DESTROY { my $s = shift; print "ok $s->[0]\n"; } + sub show { print "# @_\nnot ok $_[0][0]\n" if @_ != 5; } + sub start { push @_, 1, "foo", {}; goto &show; } + for (9..11) { start(bless([$_]), 'bar'); } +} + +sub auto { + goto &loadit; +} + +sub AUTOLOAD { print @_ } + +auto("ok 12\n"); + $wherever = FINALE; goto $wherever; diff --git a/t/op/goto_xs.t b/t/op/goto_xs.t index a35575eb26..8d9bca1cd6 100755 --- a/t/op/goto_xs.t +++ b/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/t/op/grent.t b/t/op/grent.t new file mode 100755 index 0000000000..761d8b9cf6 --- /dev/null +++ b/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/t/op/grep.t b/t/op/grep.t new file mode 100755 index 0000000000..45d0e25a27 --- /dev/null +++ b/t/op/grep.t @@ -0,0 +1,31 @@ +#!./perl + +# +# grep() and map() tests +# + +print "1..3\n"; + +$test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + my @lol = ([qw(a b c)], [], [qw(1 2 3)]); + my @mapped = map {scalar @$_} @lol; + ok "@mapped", "3 0 3"; + $test++; + + my @grepped = grep {scalar @$_} @lol; + ok "@grepped", "$lol[0] $lol[2]"; + $test++; + + @grepped = grep { $_ } @mapped; + ok "@grepped", "3 3"; + $test++; +} + diff --git a/t/op/groups.t b/t/op/groups.t index 47aabe3d7b..f46af93bd3 100755 --- a/t/op/groups.t +++ b/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'; + +# 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"; @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..23\n"; +print "1..30\n"; # type coersion on assignment $foo = 'foo'; @@ -62,7 +62,7 @@ if (defined $baa) { # fact that %X::Y:: is stored in %X:: isn't documented. # (I hope.) -{ package Foo::Bar } +{ package Foo::Bar; $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"; @@ -95,4 +95,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/t/op/hashwarn.t b/t/op/hashwarn.t index 6343a2a8d5..634e7e1f25 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; diff --git a/t/op/join.t b/t/op/join.t index eec4611e62..def5a9e9fa 100755 --- a/t/op/join.t +++ b/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/t/op/lex_assign.t b/t/op/lex_assign.t new file mode 100755 index 0000000000..b5c471a5a0 --- /dev/null +++ b/t/op/lex_assign.t @@ -0,0 +1,305 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +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..", (8 + @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"; + +{ # 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"; + +} + +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/t/op/lfs.t b/t/op/lfs.t new file mode 100644 index 0000000000..ae6aac6079 --- /dev/null +++ b/t/op/lfs.t @@ -0,0 +1,177 @@ +# 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 { + # Don't bother if there are no quads. + 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'; + # 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 bye { + close(BIG); + unlink "big"; + 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 is not +# allowed to write large files or that the file system you are running +# the tests on doesn't support large files, or both. You may also need +# to reconfigure your kernel. (This is all very system-dependent.) +# +# Perl may still be able to support large files, once you have +# such a process and such a (file) system. +# +EOM +} + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files\n"; + bye(); +} + +# Then try to 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, ">big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; +seek(BIG, 1_000_000, $SEEK_SET); +print BIG "big"; +close(BIG); + +my @s; + +@s = stat("big"); + +print "# @s\n"; + +my $BLOCKSIZE = 512; # is this really correct everywhere? + +unless (@s == 13 && + $s[7] == 1_000_003 && + defined $s[12] && + $BLOCKSIZE * $s[12] < 1_000_003) { + print "1..0\n# no sparse files?\n"; + bye(); +} + +# 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. + +open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; +seek(BIG, 5_000_000_000, $SEEK_SET); +# 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"; +my $close = close BIG if $print; +unless ($print && $close) { + $ENV{LC_ALL} = "C"; + if ($! =~/File too large/) { + print "1..0\n# writing past 2GB failed\n"; + explain(); + } + bye(); +} + +@s = stat("big"); + +print "# @s\n"; + +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 + +# eof diff --git a/t/op/list.t b/t/op/list.t index a4230b681b..4d7a2d5444 100755 --- a/t/op/list.t +++ b/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/t/op/local.t b/t/op/local.t index 2f674d103b..b478e01993 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ - -print "1..58\n"; +print "1..69\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -198,3 +196,42 @@ print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n"; print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n"; print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n"; +# does implicit localization in foreach skip magic? + +$_ = "ok 59,ok 60,"; +my $iter = 0; +while (/(o.+?),/gc) { + print "$1\n"; + foreach (1..1) { $iter++ } + if ($iter > 2) { print "not ok 60\n"; last; } +} + +{ + package UnderScore; + sub TIESCALAR { bless \my $self, shift } + sub FETCH { die "read \$_ forbidden" } + sub STORE { die "write \$_ forbidden" } + tie $_, __PACKAGE__; + my $t = 61; + my @tests = ( + "Nesting" => sub { print '#'; for (1..3) { print } + print "\n" }, 1, + "Reading" => sub { print }, 0, + "Matching" => sub { $x = /badness/ }, 0, + "Concat" => sub { $_ .= "a" }, 0, + "Chop" => sub { chop }, 0, + "Filetest" => sub { -x }, 0, + "Assignment" => sub { $_ = "Bad" }, 0, + # XXX whether next one should fail is debatable + "Local \$_" => sub { local $_ = 'ok?'; print }, 0, + "for local" => sub { for("#ok?\n"){ print } }, 1, + ); + while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { + print "# Testing $name\n"; + eval { &$code }; + print(($ok xor $@) ? "ok $t\n" : "not ok $t\n"); + ++$t; + } + untie $_; +} + diff --git a/t/op/lop.t b/t/op/lop.t new file mode 100755 index 0000000000..f15201ff09 --- /dev/null +++ b/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/t/op/magic.t b/t/op/magic.t index 61e4522913..31765e2c50 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -4,7 +4,7 @@ BEGIN { $^W = 1; $| = 1; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } @@ -22,6 +22,7 @@ sub ok { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; +$Is_Cygwin = $^O =~ /cygwin/; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); print "1..35\n"; @@ -111,6 +112,11 @@ 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$##; + } else { $wd = '.'; } @@ -120,8 +126,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,7 +142,13 @@ __END__ :endofperl EOT } - $s1 = $s2 = "\$^X is $perl, \$0 is $script\n"; + 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 = "\$^X is $perl, \$0 is $script\n"; ok 19, open(SCRIPT, ">$script"), $!; ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; #!$wd/perl @@ -145,12 +158,14 @@ 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; 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 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1:"; $_ = `$perl $script`; - s/.exe//i if $Is_Dos; + s/\.exe//i if $Is_Dos; + s{\\}{/}g; ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`"; ok 25, unlink($script), $!; } @@ -179,7 +194,7 @@ else { } { - local $SIG{'__WARN__'} = sub { print "not " }; + local $SIG{'__WARN__'} = sub { print "# @_\nnot " }; $! = undef; print "ok 31\n"; } diff --git a/t/op/method.t b/t/op/method.t index f1b1888ef6..1c6f3c5d9d 100755 --- a/t/op/method.t +++ b/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/t/op/misc.t b/t/op/misc.t index 449d87cea1..926c7f38d0 100755 --- a/t/op/misc.t +++ b/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,19 +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"; @@ -74,7 +80,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); ######## @@ -86,7 +92,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} @@ -343,7 +349,7 @@ 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. ######## @@ -417,3 +423,85 @@ EXPECT destroyed destroyed ######## +BEGIN { + $| = 1; + $SIG{__WARN__} = sub { + eval { print $_[0] }; + die "bar\n"; + }; + warn "foo\n"; +} +EXPECT +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/(?p{ $obj->method })/'; + $re; +} +EXPECT +######## +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +EXPECT +ZZZ +######## +eval ' +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +'; +EXPECT +ZZZ +######## +-w +if (@ARGV) { print "" } +else { + if ($x == 0) { print "" } else { print $x } +} +EXPECT +Use of uninitialized value at - line 4. diff --git a/t/op/mkdir.t b/t/op/mkdir.t index 5ba0a0f18d..4bd1b21c80 100755 --- a/t/op/mkdir.t +++ b/t/op/mkdir.t @@ -4,10 +4,18 @@ print "1..7\n"; -$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`; +if ($^O eq 'VMS') { # May as well test the library too + unshift @INC, '../lib'; + require File::Path; + File::Path::rmtree('blurfl'); +} +else { + $^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf 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"); @@ -15,4 +23,4 @@ print ($! =~ /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/ ? "ok 7\n" : "not ok 7\n"); +print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n"); diff --git a/t/op/nothread.t b/t/op/nothread.t index a0d444d90b..a434956cb0 100755 --- a/t/op/nothread.t +++ b/t/op/nothread.t @@ -6,12 +6,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = "../lib"; + unshift @INC, "../lib"; require Config; import Config; if ($Config{'usethreads'}) { - print "1..0\n"; + print "1..0 # Skip: this perl is threaded\n"; exit 0; } } diff --git a/t/op/numconvert.t b/t/op/numconvert.t new file mode 100755 index 0000000000..f71fd6c141 --- /dev/null +++ b/t/op/numconvert.t @@ -0,0 +1,185 @@ +#!./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 + +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/t/op/oct.t b/t/op/oct.t index 24b5c4309d..27ac5aa042 100755 --- a/t/op/oct.t +++ b/t/op/oct.t @@ -1,14 +1,53 @@ #!./perl -# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ - -print "1..8\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 "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/t/op/ord.t b/t/op/ord.t index 37128382d8..bc6d924554 100755 --- a/t/op/ord.t +++ b/t/op/ord.t @@ -1,16 +1,16 @@ #!./perl -# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $ - print "1..3\n"; # compile time evaluation -if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";} +# 65 ASCII +# 193 EBCDIC +if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} # run time evaluation $x = 'ABC'; -if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";} +if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} -if (chr 65 == A) {print "ok 3\n";} else {print "not ok 3\n";} +if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op/pack.t b/t/op/pack.t index b8aece6b6b..082b954756 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -1,8 +1,12 @@ #!./perl -# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} -print "1..56\n"; +print "1..148\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 @@ -30,7 +34,10 @@ print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ? "ok 6\n" : "not ok 6 $x\n"; -print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == 129 +my $sum = 129; # ASCII +$sum = 103 if ($Config{ebcdic} eq 'define'); + +print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ? "ok 7\n" : "not ok 7 $x\n"; open(BIN, "./perl") || open(BIN, "./perl.exe") @@ -154,3 +161,211 @@ foreach my $t (@templates) { unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i)); print "ok ", $test++, "\n"; } + +# 57..60: uuencode/decode + +# Note that first uuencoding known 'text' data and then checking the +# binary values of the uuencoded version would not be portable between +# character sets. Uuencoding is meant for encoding binary data, not +# text data. + +$in = pack 'C*', 0 .. 255; + +# just to be anal, we do some random tr/`/ / +$uu = <<'EOUU'; +M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL +M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9 +M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6& +MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S +MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@ +?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` +EOUU + +$_ = $uu; +tr/ /`/; +print "not " unless pack('u', $in) eq $_; +print "ok ", $test++, "\n"; + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +$in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; +$uu = <<'EOUU'; +M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F +&8%P:```` +EOUU + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +# 60 identical to 59 except that backquotes have been changed to spaces + +$uu = <<'EOUU'; +M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F +&8%P: +EOUU + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +# 61..72: test the ascii template types (A, a, Z) + +print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; +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 "ok ", $test++, "\n"; + +print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\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 + +print "not " unless length(pack("s!", 0)) == $Config{shortsize}; +print "ok ", $test++, "\n"; + +print "not " unless length(pack("i!", 0)) == $Config{intsize}; +print "ok ", $test++, "\n"; + +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 "ok ", $test++, "\n"; + +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 "ok ", $test++, "\n"; + +# 79..138: pack <-> unpack bijectionism + +# 79.. 83 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 +foreach my $C (0, 1, 127, 128, 255) { + print "not " unless unpack("C", pack("C", $C)) == $C; + print "ok ", $test++, "\n"; +} + +# 89.. 93: 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 +foreach my $S (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("S", pack("S", $S)) == $S; + print "ok ", $test++, "\n"; +} + +# 99..103: 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 +foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("I", pack("I", $I)) == $I; + print "ok ", $test++, "\n"; +} + +# 109..113: 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 +foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("L", pack("L", $L)) == $L; + print "ok ", $test++, "\n"; +} + +# 119..123: 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 +foreach my $v (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("v", pack("v", $v)) == $v; + print "ok ", $test++, "\n"; +} + +# 129..133: 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 +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 + +print "not " unless pack("n", 0xdead) eq "\xde\xad"; +print "ok ", $test++, "\n"; + +print "not " unless pack("v", 0xdead) eq "\xad\xde"; +print "ok ", $test++, "\n"; + +print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; +print "ok ", $test++, "\n"; + +print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; +print "ok ", $test++, "\n"; + +# 143..148: # + +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++; + diff --git a/t/op/pat.t b/t/op/pat.t index 7d4278f38a..6312c75cea 100755 --- a/t/op/pat.t +++ b/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..141\n"; +print "1..188\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,26 @@ print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; print "ok $test\n"; $test++; +my $matched; +$matched = qr/\((?:(?>[^()]+)|(?p{$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"; @@ -595,3 +609,259 @@ 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++; + diff --git a/t/op/pwent.t b/t/op/pwent.t new file mode 100755 index 0000000000..ca14a99eec --- /dev/null +++ b/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/t/op/quotemeta.t b/t/op/quotemeta.t index 20dd312b31..60e5b7be05 100755 --- a/t/op/quotemeta.t +++ b/t/op/quotemeta.t @@ -1,14 +1,32 @@ #!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + print "1..15\n"; -$_=join "", map chr($_), 32..127; +if ($Config{ebcdic} eq 'define') { + $_=join "", map chr($_), 129..233; + + # 105 characters - 52 letters = 53 backslashes + # 105 characters + 53 backslashes = 158 characters + $_=quotemeta $_; + if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} + # 104 non-backslash characters + if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} +} else { # some ASCII descendant, then. + $_=join "", map chr($_), 32..127; -# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes -# 96 characters + 33 backslashes = 129 characters -$_=quotemeta $_; -if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} -# 95 non-backslash characters -if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} + # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes + # 96 characters + 33 backslashes = 129 characters + $_=quotemeta $_; + if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} + # 95 non-backslash characters + if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} +} if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} diff --git a/t/op/rand.t b/t/op/rand.t index c779f9dad9..97019bb099 100755 --- a/t/op/rand.t +++ b/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/t/op/range.t b/t/op/range.t index 7999b869cb..1698db4a55 100755 --- a/t/op/range.t +++ b/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\n"; +print "1..13\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -46,3 +46,21 @@ foreach ('09'..'08') { print "not " unless join(",", @y) eq join(",", @x); print "ok 10\n"; +# check bounds +@a = 0x7ffffffe..0x7fffffff; +print "not " unless "@a" eq "2147483646 2147483647"; +print "ok 11\n"; + +@a = -0x7fffffff..-0x7ffffffe; +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"; +} diff --git a/t/op/re_tests b/t/op/re_tests index 7ac20c3852..b35e964dc1 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -151,8 +151,8 @@ a[bcd]+dcdcde adcdcde n - - (bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz- ((((((((((a)))))))))) a y $10 a ((((((((((a))))))))))\10 aa y $& aa -((((((((((a))))))))))\41 aa n - - -((((((((((a))))))))))\41 a! y $& a! +((((((((((a))))))))))${bang} aa n - - +((((((((((a))))))))))${bang} a! y $& a! (((((((((a))))))))) a y $& a multiple words of text uh-uh n - - multiple words multiple words, yeah y $& multiple words @@ -291,8 +291,8 @@ a[-]?c ac y $& ac '(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ- '((((((((((a))))))))))'i A y $10 A '((((((((((a))))))))))\10'i AA y $& AA -'((((((((((a))))))))))\41'i AA n - - -'((((((((((a))))))))))\41'i A! y $& A! +'((((((((((a))))))))))${bang}'i AA n - - +'((((((((((a))))))))))${bang}'i A! y $& A! '(((((((((a)))))))))'i A y $& A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A '(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C @@ -335,6 +335,9 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce ^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa ^(a(?(1)\1)){4}$ aaaaaaaaa n - - ^(a(?(1)\1)){4}$ aaaaaaaaaaa n - - +((a{4})+) aaaaaaaaa y $1 aaaaaaaa +(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa +(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa (?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r (?<=a)b ab y $& b (?<=a)b cb n - - @@ -399,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 @@ -471,15 +474,268 @@ $(?<=^(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-\w] - c - /[a-\w]/: invalid [] range in regexp +[\w-z] - c - /[\w-z]/: invalid [] range in regexp +[0-[:digit:]] - c - /[0-[:digit:]]/: invalid [] range in regexp +[[:digit:]-9] - c - /[[:digit:]-9]/: invalid [] range in regexp diff --git a/t/op/readdir.t b/t/op/readdir.t index ca19ebc7db..aea976823a 100755 --- a/t/op/readdir.t +++ b/t/op/readdir.t @@ -5,6 +5,12 @@ 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/t/op/ref.t b/t/op/ref.t index 1d70f9fd4c..a2baab8e3b 100755 --- a/t/op/ref.t +++ b/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/t/op/regexp.t b/t/op/regexp.t index 0ec069b19a..4ffe1362c6 100755 --- a/t/op/regexp.t +++ b/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>. # @@ -24,18 +26,16 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # -# \n in the tests are interpolated. +# \n in the tests are interpolated, as are variables of the form ${\w+}. # # If you want to add a regular expression test that can't be expressed # in this format, don't add it here: put it in op/pat.t instead. BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } -use re 'eval'; - $iters = shift || 1; # Poor man performance suite, 10000 is OK. open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || @@ -46,6 +46,10 @@ $numtests = $.; 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"; TEST: @@ -57,11 +61,18 @@ while (<TESTS>) { infty_subst(\$pat); infty_subst(\$expect); $pat = "'$pat'" unless $pat =~ /^[:']/; + $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 = $@ ); @@ -69,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/t/op/repeat.t b/t/op/repeat.t index 54fa590836..c030ba9a12 100755 --- a/t/op/repeat.t +++ b/t/op/repeat.t @@ -2,7 +2,7 @@ # $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ -print "1..19\n"; +print "1..20\n"; # compile time @@ -40,3 +40,59 @@ print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n"; print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n"; 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, +# 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. +# +# 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: +# +# (1) len == 1 +# (2) "from" had the 8th bit on in its single character +# (3) count > 7 (the 'x' count > 16) +# (4) the highest optimization level was used in compilation +# (which is the default when compiling Perl) +# +# The bug looked like this (. being the eight-bit character and ? being \xff): +# +# 16 ................ +# 17 .........???????. +# 18 .........???????.. +# 19 .........???????... +# 20 .........???????.... +# 21 .........???????..... +# 22 .........???????...... +# 23 .........???????....... +# 24 .........???????.??????? +# 25 .........???????.???????. +# +# The bug was triggered in the "if (len == 1)" branch. The fix +# was to introduce a new temporary variable. In diff -u format: +# +# register char *frombase = from; +# +# if (len == 1) { +#- todo = *from; +#+ register char c = *from; +# while (count-- > 0) +#- *to++ = todo; +#+ *to++ = c; +# 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. +# +# jhi@iki.fi +# +print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n"; diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 307e2a0bb5..a1551775e3 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -7,7 +7,7 @@ ## 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; @@ -35,7 +35,7 @@ for (@prgs){ `MCR $^X "-I[-.lib]" $switch $tmpfile` : $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 @@ -315,3 +315,23 @@ main|-|9|main::__ANON__ In DIE main|-|10|(eval) main|-|10|main::foo +######## +package TEST; + +sub TIEARRAY { + return bless [qw(foo fee fie foe)], $_[0]; +} +sub FETCH { + my ($s,$i) = @_; + if ($i) { + goto bbb; + } +bbb: + return $s->[$i]; +} + +package main; +tie my @bar, 'TEST'; +print join('|', @bar[0..3]), "\n"; +EXPECT +foo|fee|fie|foe diff --git a/t/op/sort.t b/t/op/sort.t index a6829e01e4..f7bba3d263 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -1,25 +1,51 @@ #!./perl -# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +print "1..38\n"; -print "1..21\n"; +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +my $upperfirst = 'A' lt 'a'; + +# Beware: in future this may become hairier because of possible +# collation complications: qw(A a B c) can be sorted at least as +# any of the following +# +# A a B b +# A B a b +# a b A B +# a A b B +# +# All the above orders make sense. +# +# That said, EBCDIC sorts all small letters first, as opposed +# to ASCII which sorts all big letters first. + @harry = ('dog','cat','x','Cain','Abel'); @george = ('gone','chased','yz','punished','Axed'); $x = join('', sort @harry); -print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); -print "# x = '$x'\n"; +$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)); -print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); -print "# x = '$x'\n"; +$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 @george, 'to', @harry); -print ($x eq 'AbelAxedCaincatchaseddoggonepunishedtoxyz'?"ok 3\n":"not ok 3\n"); -print "# x = '$x'\n"; +$expected = $upperfirst ? + 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : + 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 3\n":"not ok 3\n"); @a = (); @b = reverse @a; @@ -47,7 +73,9 @@ print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); -print ($x eq 'xdogcatCainAbel' ? "ok 10\n" : "not ok 10\n"); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 10: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); # literals, combinations @@ -102,3 +130,76 @@ eval <<'CODE'; my @result = sort 'one', 'two'; CODE print $@ ? "not ok 21\n# $@" : "ok 21\n"; + +{ + 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"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@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 26\n" : "not ok 26 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); +} + +## exercise sort builtins... ($a <=> $b already tested) +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { $b <=> $a } @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); +print "# x = '@b'\n"; +$x = join('', sort { $a cmp $b } @harry); +$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; +print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); +print "# x = '$x'; expected = '$expected'\n"; +$x = join('', sort { $b cmp $a } @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); +print "# x = '$x'; expected = '$expected'\n"; +{ + use integer; + @b = sort { $a <=> $b } @a; + print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); + print "# x = '@b'\n"; + @b = sort { $b <=> $a } @a; + print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); + print "# x = '@b'\n"; + $x = join('', sort { $a cmp $b } @harry); + $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; + print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); + print "# x = '$x'; expected = '$expected'\n"; + $x = join('', sort { $b cmp $a } @harry); + $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; + print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); + print "# x = '$x'; expected = '$expected'\n"; +} + +# test that an optimized-away comparison block doesn't take any other +# arguments away with it +$x = join('', sort { $a <=> $b } 3, 1, 2); +print $x eq "123" ? "ok 37\n" : "not ok 37\n"; + +# test sorting in non-main package +package Foo; +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { $b <=> $a } @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n"); +print "# x = '@b'\n"; diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 7556c80a41..ef5b94cb11 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -14,8 +14,8 @@ $SIG{__WARN__} = sub { }; $w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,65,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","hi",123,0,456,0,ord('A'),3.0999,11); +if ($x eq ' hi 123 %foo 456 0A3.1 1011' && $w == 0) { print "ok 1\n"; } else { print "not ok 1 '$x'\n"; diff --git a/t/op/stat.t b/t/op/stat.t index 03bfd8da39..0af55bbaab 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; @@ -13,28 +13,40 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; +$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless ($Is_MSWin32 || $Is_Dos); +$DEV = `ls -l /dev` unless $Is_Dosish; 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 || ($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; +} else { + print "# open failed: $!\nnot ok 1\nnot ok 2\n"; +} -if ($Is_MSWin32 || $Is_Dos) { 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`; } @@ -42,15 +54,19 @@ else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.stat.tmp'); -if ($Is_MSWin32 || $Is_Dos || $Config{dont_use_nlink} || $nlink == 2) - {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";} +if ($Is_Dosish || $Config{dont_use_nlink}) + {print "ok 3 # skipped: no link count\n";} +elsif ($nlink == 2) + {print "ok 3\n";} +else {print "# \$nlink is |$nlink|\nnot ok 3\n";} -if ( ($mtime && $mtime != $ctime) - || $Is_MSWin32 - || $Is_Dos +if ( $Is_Dosish || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug || $cwd =~ m#/afs/# || $^O eq 'amigaos') { + print "ok 4 # skipped: different semantic of mtime/ctime\n"; +} +elsif ( ($mtime && $mtime != $ctime) ) { print "ok 4\n"; } else { @@ -60,7 +76,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` } @@ -71,7 +87,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'; @@ -88,10 +104,15 @@ 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";} -if ($Is_MSWin32 or $Is_Dos or -x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";} +if ($Is_Dosish) {print "ok 20 # skipped: -x by extension\n";} +elsif (-x 'Op.stat.tmp') {print "ok 20\n";} +else {print "not ok 20\n";} if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";} if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";} @@ -99,7 +120,7 @@ if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";} if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";} if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";} -if (!($Is_MSWin32 || $Is_Dos) and `ls -l perl` =~ /^l.*->/) { +if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) { if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";} } else { @@ -142,7 +163,9 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_MSWin32 || $Is_Dos) {print "ok 35\n"; goto tty_test;} +if ($^O eq 'amigaos' or $Is_Dosish) { + print "ok 35 # skipped: no -u\n"; goto tty_test; +} $cnt = $uid = 0; @@ -175,14 +198,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 { @@ -240,4 +272,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/t/op/subst.t b/t/op/subst.t index 2d42eeb386..2d15df4dc1 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -1,12 +1,12 @@ #!./perl - BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; } -print "1..71\n"; +print "1..83\n"; $x = 'foo'; $_ = "x"; @@ -187,13 +187,22 @@ tr/a-z/A-Z/; print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; # same as tr/A-Z/a-z/; -y[\101-\132][\141-\172]; +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]; +} print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n"; -$_ = '+,-'; -tr/+--/a-c/; -print $_ eq 'abc' ? "ok 54\n" : "not ok 54\n"; +if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 && + ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) { + $_ = '+,-'; + tr/+--/a-c/; + print "not " unless $_ eq 'abc'; +} +print "ok 54\n"; $_ = '+,-'; tr/+\--/a\/c/; @@ -303,6 +312,67 @@ 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"; + + diff --git a/t/op/subst_amp.t b/t/op/subst_amp.t new file mode 100755 index 0000000000..e2e7c0e542 --- /dev/null +++ b/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/t/op/subst_wamp.t b/t/op/subst_wamp.t new file mode 100755 index 0000000000..b716b30915 --- /dev/null +++ b/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/t/op/sysio.t b/t/op/sysio.t index 826cf383ae..22e60e30fc 100755 --- a/t/op/sysio.t +++ b/t/op/sysio.t @@ -1,12 +1,13 @@ #!./perl -print "1..36\n"; +print "1..39\n"; chdir('op') || die "sysio.t: cannot look for myself: $!"; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; -$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos'); +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' || + $^O eq 'mpeix'); $x = 'abc'; @@ -151,6 +152,21 @@ if ($reopen) { # must close file to update EOF marker for stat print 'not ' unless (-s $outfile == 7); print "ok 28\n"; +# with implicit length argument +print 'not ' unless (syswrite(O, $x) == 3); +print "ok 29\n"; + +# $a still intact +print 'not ' unless ($x eq "abc"); +print "ok 30\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 10); +print "ok 31\n"; + close(O); open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; @@ -158,30 +174,30 @@ open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; $b = 'xyz'; # reading too much only return as much as available -print 'not ' unless (sysread(I, $b, 100) == 7); -print "ok 29\n"; +print 'not ' unless (sysread(I, $b, 100) == 10); +print "ok 32\n"; # this we should have -print 'not ' unless ($b eq '#!ererl'); -print "ok 30\n"; +print 'not ' unless ($b eq '#!ererlabc'); +print "ok 33\n"; # test sysseek print 'not ' unless sysseek(I, 2, 0) == 2; -print "ok 31\n"; +print "ok 34\n"; sysread(I, $b, 3); print 'not ' unless $b eq 'ere'; -print "ok 32\n"; +print "ok 35\n"; print 'not ' unless sysseek(I, -2, 1) == 3; -print "ok 33\n"; +print "ok 36\n"; sysread(I, $b, 4); print 'not ' unless $b eq 'rerl'; -print "ok 34\n"; +print "ok 37\n"; print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; -print "ok 35\n"; +print "ok 38\n"; print 'not ' if defined sysseek(I, -1, 1); -print "ok 36\n"; +print "ok 39\n"; close(I); diff --git a/t/op/taint.t b/t/op/taint.t index f2181d82fd..fdd1c79b83 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -9,12 +9,23 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use strict; use Config; +# We do not want the whole taint.t to fail +# 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'; + } +} + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -29,9 +40,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 } @@ -360,7 +371,12 @@ else { test 71, eval { open FOO, $foo } eq '', 'open for read'; test 72, $@ eq '', $@; # NB: This should be allowed - test 73, $! == 2 || ($Is_Dos && $! == 22); # File not found + + # Try first new style but allow also old style. + test 73, $!{ENOENT} || + $! == 2 || # File not found + ($Is_Dos && $! == 22) || + ($^O eq 'mint' && $! == 33); test 74, eval { open FOO, "> $foo" } eq '', 'open for write'; test 75, $@ =~ /^Insecure dependency/, $@; @@ -374,10 +390,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/, $@; } diff --git a/t/op/tie.t b/t/op/tie.t index 77e74db4e2..105b1d6f18 100755 --- a/t/op/tie.t +++ b/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,8 @@ EXPECT ######## # strict behaviour, without any extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; +#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -86,8 +86,8 @@ EXPECT ######## # strict behaviour, with 1 extra references generating an error -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; +#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; @@ -96,8 +96,8 @@ 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'; +#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -107,8 +107,8 @@ 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'; +#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -117,8 +117,8 @@ EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; +#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -128,8 +128,8 @@ EXPECT ######## # strict error behaviour, with 2 extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; +#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; @@ -139,17 +139,42 @@ untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. -#no warning 'untie'; -local $^W = 0 ; +no warnings 'untie'; +#local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { - #use warning 'untie'; - local $^W = 1 ; + use warnings 'untie'; + #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; } untie %H; EXPECT +######## + +# verify no leak when underlying object is selfsame tied variable +my ($a, $b); +sub Self::TIEHASH { bless $_[1], $_[0] } +sub Self::DESTROY { $b = $_[0] + 0; } +{ + my %b5; + $a = \%b5 + 0; + tie %b5, 'Self', \%b5; +} +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/t/op/tiearray.t b/t/op/tiearray.t index 8e78b2f76b..25fda3fb03 100755 --- a/t/op/tiearray.t +++ b/t/op/tiearray.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my %seen; diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t index e3d24723a9..6ae3faaaec 100755 --- a/t/op/tiehandle.t +++ b/t/op/tiehandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my @expect; @@ -64,7 +64,7 @@ sub READ { sub WRITE { compare(WRITE => @_); $data = substr($_[1],$_[3] || 0, $_[2]); - 4; + length($data); } sub CLOSE { @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..23\n"; +print "1..29\n"; my $fh = gensym; @@ -132,6 +132,20 @@ $r = syswrite $fh,$buf,4,1; ok($r == 4); ok($data eq "wert"); +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 4); +$data = ""; +$r = syswrite $fh,$buf,4; +ok($r == 4); +ok($data eq "qwer"); + +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 6); +$data = ""; +$r = syswrite $fh,$buf; +ok($r == 6); +ok($data eq "qwerty"); + @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); diff --git a/t/op/time.t b/t/op/time.t index 1bec442fe2..658f9f35b9 100755 --- a/t/op/time.t +++ b/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|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/t/op/tr.t b/t/op/tr.t new file mode 100755 index 0000000000..4e6667cd7f --- /dev/null +++ b/t/op/tr.t @@ -0,0 +1,39 @@ +# tr.t + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib"; +} + +print "1..4\n"; + +$_ = "abcdefghijklmnopqrstuvwxyz"; + +tr/a-z/A-Z/; + +print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; +print "ok 1\n"; + +tr/A-Z/a-z/; + +print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz"; +print "ok 2\n"; + +tr/b-y/B-Y/; + +print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz"; +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"; + + tr/I-J/i-j/; + + print "not " unless $_ eq "i\xcaj"; + print "ok 4\n"; +} +# diff --git a/t/op/undef.t b/t/op/undef.t index 8ab2ec421f..8944ee3976 100755 --- a/t/op/undef.t +++ b/t/op/undef.t @@ -1,8 +1,11 @@ #!./perl -# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -print "1..21\n"; +print "1..27\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -54,3 +57,25 @@ sub foo { print "ok 19\n"; } print defined &foo ? "ok 20\n" : "not ok 20\n"; undef &foo; print defined(&foo) ? "not ok 21\n" : "ok 21\n"; + +eval { undef $1 }; +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/t/op/universal.t b/t/op/universal.t index bd6c73afe9..eb6ec3ce97 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } print "1..72\n"; @@ -75,7 +75,11 @@ test ! (eval { $a->VERSION(2.719) }) && test (eval { $a->VERSION(2.718) }) && ! $@; my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -test $subs eq "VERSION can isa"; +if ('a' lt 'A') { + test $subs eq "can isa VERSION"; +} else { + test $subs eq "VERSION can isa"; +} test $a->isa("UNIVERSAL"); @@ -86,7 +90,11 @@ test $a->isa("UNIVERSAL"); my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug -test $sub2 eq "VERSION can import isa"; +if ('a' lt 'A') { + test $sub2 eq "can import isa VERSION"; +} else { + test $sub2 eq "VERSION can import isa"; +} eval 'sub UNIVERSAL::sleep {}'; test $a->can("sleep"); diff --git a/t/op/write.t b/t/op/write.t index 705fa7977b..9918b2f57f 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -2,7 +2,7 @@ # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ -print "1..5\n"; +print "1..6\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -167,3 +167,26 @@ for (0..10) { print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; +$^A = ''; + +# more test + +format OUT3 = +^<<<<<<... +$foo +. + +open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$foo = 'fit '; +write(OUT3); +close OUT3; + +$right = +"fit\n"; + +if (`$CAT Op_write.tmp` eq $right) + { print "ok 6\n"; unlink 'Op_write.tmp'; } +else + { print "not ok 6\n"; } + diff --git a/t/pod/emptycmd.t b/t/pod/emptycmd.t new file mode 100755 index 0000000000..59e395ea04 --- /dev/null +++ b/t/pod/emptycmd.t @@ -0,0 +1,21 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/emptycmd.xr b/t/pod/emptycmd.xr new file mode 100644 index 0000000000..f06d2dbb09 --- /dev/null +++ b/t/pod/emptycmd.xr @@ -0,0 +1,2 @@ + = this is a test of the emergency broadcast system + diff --git a/t/pod/for.t b/t/pod/for.t new file mode 100755 index 0000000000..44af44f17d --- /dev/null +++ b/t/pod/for.t @@ -0,0 +1,59 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/for.xr b/t/pod/for.xr new file mode 100644 index 0000000000..25794ab0fe --- /dev/null +++ b/t/pod/for.xr @@ -0,0 +1,19 @@ + 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/t/pod/headings.t b/t/pod/headings.t new file mode 100755 index 0000000000..78608d0fd9 --- /dev/null +++ b/t/pod/headings.t @@ -0,0 +1,140 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/headings.xr b/t/pod/headings.xr new file mode 100644 index 0000000000..e1277b7e37 --- /dev/null +++ b/t/pod/headings.xr @@ -0,0 +1,29 @@ +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/t/pod/include.t b/t/pod/include.t new file mode 100755 index 0000000000..4e73b78356 --- /dev/null +++ b/t/pod/include.t @@ -0,0 +1,36 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/include.xr b/t/pod/include.xr new file mode 100644 index 0000000000..1bac06adb1 --- /dev/null +++ b/t/pod/include.xr @@ -0,0 +1,23 @@ + 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/t/pod/included.t b/t/pod/included.t new file mode 100755 index 0000000000..4f171c454b --- /dev/null +++ b/t/pod/included.t @@ -0,0 +1,35 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/included.xr b/t/pod/included.xr new file mode 100644 index 0000000000..f0bc03bf09 --- /dev/null +++ b/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/t/pod/lref.t b/t/pod/lref.t new file mode 100755 index 0000000000..02e2c9e307 --- /dev/null +++ b/t/pod/lref.t @@ -0,0 +1,66 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/lref.xr b/t/pod/lref.xr new file mode 100644 index 0000000000..d8455e3874 --- /dev/null +++ b/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/t/pod/nested_items.t b/t/pod/nested_items.t new file mode 100755 index 0000000000..c8e9b22427 --- /dev/null +++ b/t/pod/nested_items.t @@ -0,0 +1,64 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/nested_items.xr b/t/pod/nested_items.xr new file mode 100644 index 0000000000..7d72bbe890 --- /dev/null +++ b/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/t/pod/nested_seqs.t b/t/pod/nested_seqs.t new file mode 100755 index 0000000000..8559f1f25f --- /dev/null +++ b/t/pod/nested_seqs.t @@ -0,0 +1,23 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/nested_seqs.xr b/t/pod/nested_seqs.xr new file mode 100644 index 0000000000..5a008c17e9 --- /dev/null +++ b/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/t/pod/oneline_cmds.t b/t/pod/oneline_cmds.t new file mode 100755 index 0000000000..28bd1d09e5 --- /dev/null +++ b/t/pod/oneline_cmds.t @@ -0,0 +1,46 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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/t/pod/oneline_cmds.xr b/t/pod/oneline_cmds.xr new file mode 100644 index 0000000000..e1277b7e37 --- /dev/null +++ b/t/pod/oneline_cmds.xr @@ -0,0 +1,29 @@ +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/t/pod/poderrs.t b/t/pod/poderrs.t new file mode 100755 index 0000000000..591bd2a86d --- /dev/null +++ b/t/pod/poderrs.t @@ -0,0 +1,39 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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}; + + +__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! + +=cut diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr new file mode 100644 index 0000000000..a7bc42d956 --- /dev/null +++ b/t/pod/poderrs.xr @@ -0,0 +1,11 @@ +*** ERROR: Unknown command "unknown1" at line 21 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "N" at line 21 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "D" at line 22 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "Q" at line 25 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "A" at line 26 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "V" at line 27 of file t/poderrs.t +*** ERROR: Unknown interior-sequence "Y" at line 27 of file t/poderrs.t +** Unterminated B<...> at t/poderrs.t line 31 +** Unterminated I<...> at t/poderrs.t line 30 +** Unterminated C<...> at t/poderrs.t line 33 +t/poderrs.t has 10 pod syntax errors. diff --git a/t/pod/special_seqs.t b/t/pod/special_seqs.t new file mode 100755 index 0000000000..1b31387dd3 --- /dev/null +++ b/t/pod/special_seqs.t @@ -0,0 +1,32 @@ +BEGIN { + use File::Basename; + my $THISDIR = dirname $0; + unshift @INC, $THISDIR; + 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. + +Now for the grand finale of C<$self->method()->{FIELDNAME} = {FOO=>BAR}>. + +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! + +=cut diff --git a/t/pod/special_seqs.xr b/t/pod/special_seqs.xr new file mode 100644 index 0000000000..6795de0490 --- /dev/null +++ b/t/pod/special_seqs.xr @@ -0,0 +1,15 @@ + 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. + + Now for the grand finale of `$self->method()->{FIELDNAME} = + {FOO=>BAR}'. + + 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! + diff --git a/t/pod/testcmp.pl b/t/pod/testcmp.pl new file mode 100644 index 0000000000..d61bbff3a2 --- /dev/null +++ b/t/pod/testcmp.pl @@ -0,0 +1,90 @@ +package TestCompare; + +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +use File::Basename; +use File::Spec; + +@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/t/pod/testp2pt.pl b/t/pod/testp2pt.pl new file mode 100644 index 0000000000..9df5b9f2ed --- /dev/null +++ b/t/pod/testp2pt.pl @@ -0,0 +1,178 @@ +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 Pod::PlainText; +use vars qw(@ISA @EXPORT $MYPKG); +#use strict; +#use diagnostics; +use Carp; +use Exporter; +#use File::Compare; +#use Cwd qw(abs_path); + +@ISA = qw(Pod::PlainText); +@EXPORT = qw(&testpodplaintext); +$MYPKG = eval { (caller)[0] }; + +## Hardcode settings for TERMCAP and COLUMNS so we can try to get +## reproducible results between environments +@ENV{qw(TERMCAP COLUMNS)} = ('co=72:do=^J', 72); + +sub catfile(@) { File::Spec->catfile(@_); } + +my $INSTDIR = abs_path(dirname $0); +$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'xtra'); +$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, 't', 'pod'), + catfile($INSTDIR, 't', 'pod', 'xtra') + ); + +## 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 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/t/pod/testpchk.pl b/t/pod/testpchk.pl new file mode 100644 index 0000000000..cd3c13816d --- /dev/null +++ b/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); +} + +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) { + if ( /^#*\s*(\S.*?)\s+(?:has \d+\s*)?pod syntax (?:error|OK)/ ) { + my $fname = $1; + s/^#*\s*// if ($^O eq 'MacOS'); + s/^\s*\Q$fname\E/stripname($fname)/e; + } + elsif ( /^#*\s*\*+\s*(?:ERROR|Unterminated)/ ) { + s/^#*\s*// if ($^O eq 'MacOS'); + s/of file\s+(\S.*?)\s*$/"of file ".stripname($1)/e; + s/at\s+(\S.*?)\s+line/"at ".stripname($1)." line"/e; + } + } + 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 + 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/t/pragma/constant.t b/t/pragma/constant.t index 0095f3b627..15ce319c02 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$^W |= 1} # Insist upon warnings @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..39\n"; } +BEGIN { $| = 1; print "1..46\n"; } END {print "not ok 1\n" unless $loaded;} use constant; $loaded = 1; @@ -81,7 +81,7 @@ test 18, (COUNTLIST)[1] == 4; use constant ABC => 'ABC'; test 19, "abc${\( ABC )}abc" eq "abcABCabc"; -use constant DEF => 'D', "\x45", chr 70; +use constant DEF => 'D', 'E', chr ord 'F'; test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; use constant SINGLE => "'"; @@ -139,3 +139,19 @@ test 37, @warnings && test 38, @warnings == 0, "unexpected warning"; test 39, $^W & 1, "Who disabled the warnings?"; + +use constant CSCALAR => \"ok 40\n"; +use constant CHASH => { foo => "ok 41\n" }; +use constant CARRAY => [ undef, "ok 42\n" ]; +use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; +use constant CCODE => sub { "ok $_[0]\n" }; + +print ${+CSCALAR}; +print CHASH->{foo}; +print CARRAY->[1]; +print CPHASH->{foo}; +eval q{ CPHASH->{bar} }; +test 44, scalar($@ =~ /^No such array/); +print CCODE->(45); +eval q{ CCODE->{foo} }; +test 46, scalar($@ =~ /^Constant is not a HASH/); diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 00baa6645e..82adcf3fb8 100755 --- a/t/pragma/locale.t +++ b/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,14 +34,11 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -print "1..", ($have_setlocale ? 102 : 98), "\n"; +print "1..", ($have_setlocale ? 115 : 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) = @_; @@ -216,268 +224,481 @@ 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 + +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, $_; } } - @$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_$_"); } -# Sort it now that LC_ALL has been set. +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"); + } + } + } +} + +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; + +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. + # 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{$_}; + } -for (@Locale) { - if (/[^\d_]/) { # skip digits and the _ - if (lc eq $_) { - $UPPER{$_} = uc; - } else { - $lower{$_} = lc; + debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; + debug "# lower = ", join(" ", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; + + # Find the alphabets that are not alphabets in the default locale. + + { + no locale; + + @Neoalpha = (); + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); } } -} -# Find the alphabets that are not alphabets in the default locale. + @Neoalpha = sort @Neoalpha; -{ - no locale; + 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 { + + # 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); + + my $c = "$x"; + my $z = sprintf ''; # sprintf used to reset locale to "C" + my $d = "$y"; -# Find places where the collation order differs from the default locale. + debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; -print "# testing 100\n"; -{ - my (@k, $i, $j, @d); + tryneoalpha($Locale, 104, $c eq $d); { - no locale; + my $w = 0; + local $SIG{__WARN__} = sub { $w++ }; + local $^W = 1; - @k = sort (keys %UPPER, keys %lower); - } + # the == (among other ops) used to warn for locales + # that had something else than "." as the radix character - 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]]); - } + 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"; + + debug "# 112..114: f = $f, locale = $Locale\n"; + + tryneoalpha($Locale, 112, $f == 1.23); + + tryneoalpha($Locale, 113, $f == $x); + + tryneoalpha($Locale, 114, $f == $c); } - # Cross-check those places. + debug "# testing 115 with locale '$Locale'\n"; + { + use locale; + + sub lcA { + my $lc0 = lc $_[0]; + my $lc1 = lc $_[1]; + return $lc0 cmp $lc1; + } - 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; + 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); } } -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..115) { + 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. - -{ - no locale; - $a = "qwerty"; - { - use locale; - print "not " if $a cmp "qwerty"; +# Give final advice. + +my $didwarn = 0; + +foreach (99..115) { + 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/t/pragma/locale/latin1 b/t/pragma/locale/latin1 new file mode 100644 index 0000000000..f40f7325e0 --- /dev/null +++ b/t/pragma/locale/latin1 @@ -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/t/pragma/locale/utf8 b/t/pragma/locale/utf8 new file mode 100644 index 0000000000..fbbe94fb51 --- /dev/null +++ b/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/t/pragma/overload.t b/t/pragma/overload.t index 05035c612d..ff8d8059f1 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -2,11 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -use Config; - package Oscalar; use overload ( # Anonymous subroutines: @@ -436,6 +434,487 @@ test($b, "_<oups1 >_"); # 134 test($c, "bareword"); # 135 +{ + package symbolic; # Primitive symbolic calculator + use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, + '=' => \&cpy, '++' => \&inc, '--' => \&dec; + + sub new { shift; bless ['n', @_] } + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + sub inc { $_[0] = bless ['++', $_[0], 1]; } + sub dec { $_[0] = bless ['--', $_[0], 1]; } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } +} + +{ + my $foo = new symbolic 11; + my $baz = $foo++; + test( (sprintf "%d", $foo), '12'); + test( (sprintf "%d", $baz), '11'); + my $bar = $foo; + $baz = ++$foo; + test( (sprintf "%d", $foo), '13'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '13'); + my $ban = $foo; + $baz = ($foo += 1); + test( (sprintf "%d", $foo), '14'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '14'); + test( (sprintf "%d", $ban), '13'); + $baz = 0; + $baz = $foo++; + test( (sprintf "%d", $foo), '15'); + test( (sprintf "%d", $baz), '14'); + test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); +} + +{ + my $iter = new symbolic 2; + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # The "simple" way + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my $iter = new symbolic 2; + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my ($a, $b); + symbolic->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + $a = 3; $b = 4; + test( (sprintf "%d", $c), '5'); + $a = 12; $b = 5; + test( (sprintf "%d", $c), '13'); +} + +{ + package symbolic1; # Primitive symbolic calculator + # Mutator inc/dec + use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; + + sub new { shift; bless ['n', @_] } + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } +} + +{ + my $foo = new symbolic1 11; + my $baz = $foo++; + test( (sprintf "%d", $foo), '12'); + test( (sprintf "%d", $baz), '11'); + my $bar = $foo; + $baz = ++$foo; + test( (sprintf "%d", $foo), '13'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '13'); + my $ban = $foo; + $baz = ($foo += 1); + test( (sprintf "%d", $foo), '14'); + test( (sprintf "%d", $bar), '12'); + test( (sprintf "%d", $baz), '14'); + test( (sprintf "%d", $ban), '13'); + $baz = 0; + $baz = $foo++; + test( (sprintf "%d", $foo), '15'); + test( (sprintf "%d", $baz), '14'); + test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); +} + +{ + my $iter = new symbolic1 2; + my $side = new symbolic1 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # The "simple" way + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my $iter = new symbolic1 2; + my $side = new symbolic1 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + my $pi = $side*(2**($iter+2)); + test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; + test( (sprintf "%f", $pi), '3.182598'); +} + +{ + my ($a, $b); + symbolic1->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + $a = 3; $b = 4; + test( (sprintf "%d", $c), '5'); + $a = 12; $b = 5; + test( (sprintf "%d", $c), '13'); +} + +{ + package two_face; # Scalars with separate string and + # numeric values. + sub new { my $p = shift; bless [@_], $p } + use overload '""' => \&str, '0+' => \&num, fallback => 1; + sub num {shift->[1]} + sub str {shift->[0]} +} + +{ + my $seven = new two_face ("vii", 7); + test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), + 'seven=vii, seven=7, eight=8'); + test( scalar ($seven =~ /i/), '1') +} + +{ + package sorting; + use overload 'cmp' => \∁ + sub new { my ($p, $v) = @_; bless \$v, $p } + sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } +} +{ + my @arr = map sorting->new($_), 0..12; + my @sorted1 = sort @arr; + 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--; } +} +{ + 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; + test "@cont", '23 5 fake foo'; # 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 {135} +sub last {208} diff --git a/t/pragma/strict-subs b/t/pragma/strict-subs index 61ec286eb6..deeb381473 100644 --- a/t/pragma/strict-subs +++ b/t/pragma/strict-subs @@ -277,3 +277,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/t/pragma/strict.t b/t/pragma/strict.t index fc3282089f..2b8c58735f 100755 --- a/t/pragma/strict.t +++ b/t/pragma/strict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -69,7 +69,7 @@ for (@prgs){ `MCR $^X $switch $tmpfile` : $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/t/pragma/sub_lval.t b/t/pragma/sub_lval.t new file mode 100755 index 0000000000..c382ad52ae --- /dev/null +++ b/t/pragma/sub_lval.t @@ -0,0 +1,429 @@ +print "1..46\n"; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +sub a {use attrs 'lvalue'; my $a = 34; bless \$a} # Return a temporary +sub b {use attrs '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 {use attrs 'lvalue'; $in = shift;} +sub neg {use attrs '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 {use attrs 'lvalue'; $in} +sub get_st {use attrs 'lvalue'; $blah} +sub id {use attrs 'lvalue'; shift} +sub id1 {use attrs 'lvalue'; $_[0]} +sub inc {use attrs '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 {use attrs 'lvalue'; @a} +sub b2 {use attrs 'lvalue'; @b} +sub c4 {use attrs '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 {use attrs '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 {use attrs '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 {use attrs '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 {use attrs 'lvalue';} + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv0) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " if defined $_; +print "ok 32\n"; + +sub lv1u {use attrs '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 {use attrs '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 {use attrs '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 {use attrs '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 {use attrs '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 {use attrs 'lvalue'; $newvar } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1n = (3,4); + 1; +EOE + +print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; +print "ok 44\n"; + +sub lv1nn {use attrs '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/t/pragma/subs.t b/t/pragma/subs.t index 056c4bd7cf..c8eb2c087f 100755 --- a/t/pragma/subs.t +++ b/t/pragma/subs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -49,12 +49,15 @@ for (@prgs){ `MCR $^X $switch $tmpfile` : $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 $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; $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; if ( $results =~ s/^SKIPPED\n//) { diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t new file mode 100755 index 0000000000..01b0f0529c --- /dev/null +++ b/t/pragma/utf8.t @@ -0,0 +1,82 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +print "1..12\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++; +} diff --git a/t/pragma/warn-1global b/t/pragma/warn/1global index 07b5bc8eb9..836b7f513f 100644 --- a/t/pragma/warn-1global +++ b/t/pragma/warn/1global @@ -1,5 +1,6 @@ Check existing $^W functionality + __END__ # warnable code, warnings disabled @@ -12,12 +13,14 @@ EXPECT $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 @@ -25,6 +28,7 @@ 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 @@ -110,22 +114,24 @@ Use of uninitialized value at - line 3. ######## $^W = 1; -eval "my $b ; chop $b ;" ; +eval 'my $b ; chop $b ;' ; +print $@ ; EXPECT -Use of uninitialized value at - line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value at (eval 1) line 1. ######## -eval "$^W = 1;" ; +eval '$^W = 1;' ; +print $@ ; my $b ; chop $b ; EXPECT - +Use of uninitialized value at - line 4. ######## eval {$^W = 1;} ; +print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value at - line 4. ######## { @@ -149,3 +155,35 @@ Use of uninitialized value at - line 5. -e undef EXPECT Use of uninitialized value 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 at - line 2. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use new file mode 100644 index 0000000000..4ec4da0a77 --- /dev/null +++ b/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 'blah' ; +EXPECT +unknown warning category 'blah' 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 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 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 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 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 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 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 at - line 5. +Use of uninitialized value 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 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 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 at (eval 1) line 2. +Use of uninitialized value 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 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 at - line 9. +Use of uninitialized value at - line 11. +Use of uninitialized value at - line 11. diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both new file mode 100644 index 0000000000..592724ad73 --- /dev/null +++ b/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 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 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 at - line 6. +######## + +# Check interaction of $^W and use warnings +$^W = 1 ; +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value 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 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 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 at - line 6. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value 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 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 at - line 7. diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint new file mode 100644 index 0000000000..6a08409bb2 --- /dev/null +++ b/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 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 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 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 at - line 3. diff --git a/t/pragma/warn/5nolint b/t/pragma/warn/5nolint new file mode 100644 index 0000000000..994190a855 --- /dev/null +++ b/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/t/pragma/warn/6default b/t/pragma/warn/6default new file mode 100644 index 0000000000..dd3d1825f4 --- /dev/null +++ b/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/t/pragma/warn/7fatal b/t/pragma/warn/7fatal new file mode 100644 index 0000000000..fe94511f3e --- /dev/null +++ b/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 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 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 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 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 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 at - line 5. +Use of uninitialized value 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 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 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 at (eval 1) line 2. +Use of uninitialized value 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 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/t/pragma/warn/8signal b/t/pragma/warn/8signal new file mode 100644 index 0000000000..0be2d13cc0 --- /dev/null +++ b/t/pragma/warn/8signal @@ -0,0 +1,18 @@ +Check interaction of __WARN__, __DIE__ & lexical Warnings + +TODO + +__END__ +# 8signal +BEGIN { $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 +Use of EQ is deprecated at - line 8. +WARN -- Use of EQ is deprecated at - line 6. +DIE -- Use of EQ is deprecated at - line 8. diff --git a/t/pragma/warn/av b/t/pragma/warn/av new file mode 100644 index 0000000000..79bd3b7600 --- /dev/null +++ b/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/t/pragma/warn/doio b/t/pragma/warn/doio new file mode 100644 index 0000000000..5101bdef80 --- /dev/null +++ b/t/pragma/warn/doio @@ -0,0 +1,191 @@ + doio.c + + Can't do 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 do 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 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" ; +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 is not a regular file at - line 9. +Can't do inplace edit: ./temp 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/t/pragma/warn/doop b/t/pragma/warn/doop new file mode 100644 index 0000000000..961d157502 --- /dev/null +++ b/t/pragma/warn/doop @@ -0,0 +1,25 @@ + doop.c AOK + + Malformed UTF-8 character + + +__END__ +# doop.c +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +Malformed UTF-8 character at - line 4. +######## +# doop.c +use warnings 'utf8' ; +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +no warnings 'utf8' ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +Malformed UTF-8 character at - line 5. diff --git a/t/pragma/warn/gv b/t/pragma/warn/gv new file mode 100644 index 0000000000..5ed4eca018 --- /dev/null +++ b/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/t/pragma/warn/hv b/t/pragma/warn/hv new file mode 100644 index 0000000000..c9eec028f1 --- /dev/null +++ b/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/t/pragma/warn/malloc b/t/pragma/warn/malloc new file mode 100644 index 0000000000..2f8b096a51 --- /dev/null +++ b/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/t/pragma/warn/mg b/t/pragma/warn/mg new file mode 100644 index 0000000000..a8f9dbc338 --- /dev/null +++ b/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/t/pragma/warn/op b/t/pragma/warn/op new file mode 100644 index 0000000000..e50420a8f6 --- /dev/null +++ b/t/pragma/warn/op @@ -0,0 +1,810 @@ + 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); + + Probable precedence problem on logical or at -e line 1. + use warnings 'syntax'; 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 'unsafe' ; +my $x ; +my $x ; +no warnings 'unsafe' ; +my $x ; +EXPECT +"my" variable $x masks earlier declaration in same scope at - line 4. +######## +# op.c +use warnings 'unsafe' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT +Variable "$x" will not stay shared at - line 7. +######## +# op.c +no warnings 'unsafe' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c +use warnings 'unsafe' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT +Variable "$x" may be unavailable at - line 6. +######## +# op.c +no warnings 'unsafe' ; +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 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 elem 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 +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # known scalar leak +use warnings 'unsafe' ; +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 'unsafe' ; +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 to @array will act on scalar(@array) at - line 5. +Applying substitution to @array will act on scalar(@array) at - line 6. +Can't modify private array in substitution at - line 6, near "s/a/b/ ;" +Applying character translation to @array will act on scalar(@array) at - line 7. +Applying pattern match to @array will act on scalar(@array) at - line 8. +Applying substitution to @array will act on scalar(@array) at - line 9. +Applying character translation to @array will act on scalar(@array) at - line 10. +Applying pattern match to %hash will act on scalar(%hash) at - line 11. +Applying substitution to %hash will act on scalar(%hash) at - line 12. +Applying character translation to %hash will act on scalar(%hash) at - line 13. +Applying pattern match to %hash will act on scalar(%hash) at - line 14. +Applying substitution to %hash will act on scalar(%hash) at - line 15. +Applying character translation 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 'syntax' ; +print (ABC || 1) ; +no warnings 'syntax' ; +print (ABC || 1) ; +EXPECT +Probable precedence problem on logical or at - line 3. +######## +--FILE-- abc + +--FILE-- +# op.c +use warnings 'unsafe' ; +open FH, "<abc" ; +$x = 1 if $x = <FH> ; +no warnings 'unsafe' ; +$x = 1 if $x = <FH> ; +EXPECT +Value of <HANDLE> construct can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'unsafe' ; +opendir FH, "." ; +$x = 1 if $x = readdir FH ; +no warnings 'unsafe' ; +$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 'unsafe' ; +$x = 1 if $x = <*> ; +no warnings 'unsafe' ; +$x = 1 if $x = <*> ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'unsafe' ; +%a = (1,2,3,4) ; +$x = 1 if $x = each %a ; +no warnings 'unsafe' ; +$x = 1 if $x = each %a ; +EXPECT +Value of each() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'unsafe' ; +$x = 1 while $x = <*> and 0 ; +no warnings 'unsafe' ; +$x = 1 while $x = <*> and 0 ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'unsafe' ; +opendir FH, "." ; +$x = 1 while $x = readdir FH and 0 ; +no warnings 'unsafe' ; +$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 'syntax' ; +push FRED; +no warnings 'syntax' ; +push FRED; +EXPECT +Array @FRED missing the @ in argument 1 of push() at - line 3. +######## +# op.c +use warnings 'syntax' ; +@a = keys FRED ; +no warnings 'syntax' ; +@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 'unsafe' ; + sub Fred() ; + sub Fred($) {} + use warnings 'unsafe' ; + 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 'unsafe' ; +fred() ; +sub fred ($$) {} +no warnings 'unsafe' ; +joe() ; +sub joe ($$) {} +EXPECT +main::fred() called too early to check prototype at - line 3. diff --git a/t/pragma/warn/perl b/t/pragma/warn/perl new file mode 100644 index 0000000000..45807499d6 --- /dev/null +++ b/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/t/pragma/warn/perlio b/t/pragma/warn/perlio new file mode 100644 index 0000000000..18c0dfa89f --- /dev/null +++ b/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/t/pragma/warn/perly b/t/pragma/warn/perly new file mode 100644 index 0000000000..afc5dccc72 --- /dev/null +++ b/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/t/pragma/warn/pp b/t/pragma/warn/pp new file mode 100644 index 0000000000..48b5ec86b5 --- /dev/null +++ b/t/pragma/warn/pp @@ -0,0 +1,125 @@ + pp.c TODO + + substr outside of string + $a = "ab" ; $a = 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 + + Mandatory Warnings + ------------------ + Malformed UTF-8 character + +__END__ +# pp.c +use warnings 'substr' ; +$a = "ab" ; +$a = substr($a, 4,5); +no warnings 'substr' ; +$a = "ab" ; +$a = 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 'unsafe' ; +my $a = { 1,2,3}; +no warnings 'unsafe' ; +my $b = { 1,2,3}; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp.c +use warnings 'unsafe' ; +my @a = unpack ("A,A", "22") ; +my $a = pack ("A,A", 1,2) ; +no warnings 'unsafe' ; +my @b = unpack ("A,A", "22") ; +my $b = pack ("A,A", 1,2) ; +EXPECT +Invalid type in unpack: ',' at - line 3. +Invalid type in pack: ',' at - line 4. +######## +# pp.c +use warnings 'uninitialized' ; +my $a = undef ; +my $b = $$a; +no warnings 'uninitialized' ; +my $c = $$a; +EXPECT +Use of uninitialized value at - line 4. +######## +# pp.c +use warnings 'unsafe' ; +sub foo { my $a = "a"; return $a . $a++ . $a++ } +my $a = pack("p", &foo) ; +no warnings 'unsafe' ; +my $b = pack("p", &foo) ; +EXPECT +Attempt to pack pointer to temporary value at - line 4. +######## +# pp.c +use warnings 'unsafe' ; +bless \[], "" ; +no warnings 'unsafe' ; +bless \[], "" ; +EXPECT +Explicit blessing to '' (assuming package main) at - line 3. +######## +# pp.c +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +Malformed UTF-8 character at - line 4. +######## +# pp.c +use warnings 'utf8' ; +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +no warnings 'utf8' ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +Malformed UTF-8 character at - line 5. diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl new file mode 100644 index 0000000000..70e6d60e8d --- /dev/null +++ b/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 'unsafe' ; +$_ = "abc" ; + +while ($i ++ == 0) +{ + s/ab/last/e ; +} +no warnings 'unsafe' ; +while ($i ++ == 0) +{ + s/ab/last/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'unsafe' ; +sub fred { last } +{ fred() } +no warnings 'unsafe' ; +sub joe { last } +{ joe() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +{ + eval "use warnings 'unsafe' ; last;" +} +print STDERR $@ ; +{ + eval "no warnings 'unsafe' ;last;" +} +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'unsafe' ; +@a = (1,2) ; +@b = sort { last } @a ; +no warnings 'unsafe' ; +@b = sort { last } @a ; +EXPECT +Exiting pseudo-block via last at - line 4. +Can't "last" outside a block at - line 4. +######## +# pp_ctl.c +use warnings 'unsafe' ; +$_ = "abc" ; +fred: +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +no warnings 'unsafe' ; +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'unsafe' ; +sub fred { last joe } +joe: { fred() } +no warnings 'unsafe' ; +sub Fred { last Joe } +Joe: { Fred() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +joe: +{ eval "use warnings 'unsafe' ; last joe;" } +print STDERR $@ ; +Joe: +{ eval "no warnings 'unsafe' ; last Joe;" } +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'unsafe' ; +@a = (1,2) ; +fred: @b = sort { last fred } @a ; +no warnings 'unsafe' ; +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 'unsafe' ; +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 'unsafe' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot new file mode 100644 index 0000000000..6bd315148f --- /dev/null +++ b/t/pragma/warn/pp_hot @@ -0,0 +1,192 @@ + 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 + + Read 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 + + +__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/BSD+glibc, # +# NeXT among others. glibc should be fixed in the next version, # +# but it appears other platforms have little hope. 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"; +no warnings 'closed' ; +print STDIN "anc"; +EXPECT +print on closed filehandle main::STDIN at - line 4. +######## +# 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 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 at - line 4. +######## +# pp_hot.c [pp_aassign] +use warnings 'unsafe' ; +my %X ; %X = (1,2,3) ; +no warnings 'unsafe' ; +my %Y ; %Y = (1,2,3) ; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp_hot.c [pp_aassign] +use warnings 'unsafe' ; +my %X ; %X = [1 .. 3] ; +no warnings 'unsafe' ; +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> ; +no warnings 'closed' ; +$a = <STDIN> ; +EXPECT +Read on closed filehandle main::STDIN at - line 3. +######## +# 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 + diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys new file mode 100644 index 0000000000..651cdf9515 --- /dev/null +++ b/t/pragma/warn/pp_sys @@ -0,0 +1,259 @@ + 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 [pp_send] + close STDIN; + syswrite STDIN, "fred", 1; + + Send on closed socket [pp_send] + close STDIN; + send STDIN, "fred", 1 + + bind() on closed fd [pp_bind] + close STDIN; + bind STDIN, "fred" ; + + + connect() on closed fd [pp_connect] + close STDIN; + connect STDIN, "fred" ; + + listen() on closed fd [pp_listen] + close STDIN; + listen STDIN, 2; + + accept() on closed fd [pp_accept] + close STDIN; + accept STDIN, "fred" ; + + shutdown() on closed fd [pp_shutdown] + close STDIN; + shutdown STDIN, 0; + + [gs]etsockopt() on closed fd [pp_ssockopt] + close STDIN; + setsockopt STDIN, 1,2,3; + getsockopt STDIN, 1,2; + + get{sock, peer}name() on closed fd [pp_getpeername] + close STDIN; + getsockname STDIN; + getpeername STDIN; + + 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; +no warnings 'closed' ; +write STDIN; +EXPECT +Write on closed filehandle main::STDIN at - line 6. +######## +# 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"; +no warnings 'closed' ; +printf STDIN "fred"; +EXPECT +printf on closed filehandle main::STDIN at - line 4. +######## +# 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; +no warnings 'closed' ; +syswrite STDIN, "fred", 1; +EXPECT +Syswrite on closed filehandle at - line 4. +######## +# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] +use warnings 'io' ; +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 STDIN, "fred" ; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername 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; +EXPECT +Send on closed socket at - line 22. +bind() on closed fd at - line 23. +connect() on closed fd at - line 24. +listen() on closed fd at - line 25. +accept() on closed fd at - line 26. +shutdown() on closed fd at - line 27. +[gs]etsockopt() on closed fd at - line 28. +[gs]etsockopt() on closed fd at - line 29. +get{sock, peer}name() on closed fd at - line 30. +get{sock, peer}name() on closed fd at - line 31. +######## +# 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/t/pragma/warn/regcomp b/t/pragma/warn/regcomp new file mode 100644 index 0000000000..9c3677ee10 --- /dev/null +++ b/t/pragma/warn/regcomp @@ -0,0 +1,75 @@ + 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] + /\m/ + + 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] + + + + +__END__ +# regcomp.c [S_regpiece] +use warnings 'unsafe' ; +my $a = "ABC123" ; +$a =~ /(?=a)*/ ; +no warnings 'unsafe' ; +$a =~ /(?=a)*/ ; +EXPECT +(?=a)* matches null string many times at - line 4. +######## +# regcomp.c [S_study_chunk] +use warnings 'unsafe' ; +$_ = "" ; +/(?=a)?/; +no warnings 'unsafe' ; +/(?=a)?/; +EXPECT +Strange *+?{} on zero-length expression at - line 4. +######## +# regcomp.c [S_regatom] +use warnings 'unsafe' ; +$a =~ /\m/ ; +no warnings 'unsafe' ; +EXPECT +Unrecognized escape \m passed through at - line 3. +######## +# regcomp.c [S_regpposixcc S_checkposixcc] +use warnings 'unsafe' ; +$_ = "" ; +/[:alpha:]/; +/[.bar.]/; +/[=zog=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[:zog:]/; +no warnings 'unsafe' ; +/[:alpha:]/; +/[.foo.]/; +/[=bar=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[:zog:]/; +/[[:zog:]]/; +EXPECT +Character class syntax [: :] belongs inside character classes at - line 4. +Character class syntax [. .] belongs inside character classes at - line 5. +Character class syntax [. .] is reserved for future extensions 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 [. .] is reserved for future extensions at - line 8. +Character class syntax [= =] is reserved for future extensions at - line 9. +Character class syntax [: :] belongs inside character classes at - line 10. +Character class [:zog:] unknown at - line 19. diff --git a/t/pragma/warn/regexec b/t/pragma/warn/regexec new file mode 100644 index 0000000000..b9ba790832 --- /dev/null +++ b/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 'unsafe' ; +$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 'unsafe' ; +$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 'unsafe' ; +$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 'unsafe' ; +$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/t/pragma/warn/run b/t/pragma/warn/run new file mode 100644 index 0000000000..7a4be20e70 --- /dev/null +++ b/t/pragma/warn/run @@ -0,0 +1,8 @@ + run.c + + + Mandatory Warnings ALL TODO + ------------------ + NULL OP IN RUN + +__END__ diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv new file mode 100644 index 0000000000..bac2c42545 --- /dev/null +++ b/t/pragma/warn/sv @@ -0,0 +1,282 @@ + 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 + + Reference is already weak [Perl_sv_rvweaken] <<TODO + + Mandatory Warnings + ------------------ + Malformed UTF-8 character [sv_pos_b2u] + my $a = rindex "a\xff bc ", "bc" ; + + 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 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 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 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 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 at - line 4. +######## +# sv.c +use warnings 'uninitialized' ; +my $x *= 1 ; # d +no warnings 'uninitialized' ; +my $y *= 1 ; # d +EXPECT +Use of uninitialized value 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 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 at - line 9. +######## +# sv.c +use warnings 'uninitialized' ; +$x = $y + 1 ; # f +no warnings 'uninitialized' ; +$x = $z + 1 ; # f +EXPECT +Use of uninitialized value 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 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 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 add 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 add 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 add 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 i_add 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 bit_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 'unsafe' ; +*a = undef ; +no warnings 'unsafe' ; +*b = undef ; +EXPECT +Undefined value assigned to typeglob at - line 3. +######## +# sv.c +use utf8 ; +$^W =0 ; +{ + use warnings 'utf8' ; + my $a = rindex "a\xff bc ", "bc" ; + no warnings 'utf8' ; + $a = rindex "a\xff bc ", "bc" ; +} +my $a = rindex "a\xff bc ", "bc" ; +EXPECT +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 6. +Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 10. diff --git a/t/pragma/warn/taint b/t/pragma/warn/taint new file mode 100644 index 0000000000..fd6deed60f --- /dev/null +++ b/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/t/pragma/warn/toke b/t/pragma/warn/toke new file mode 100644 index 0000000000..ee02efa813 --- /dev/null +++ b/t/pragma/warn/toke @@ -0,0 +1,611 @@ +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() + + Use of \\x{} without utf8 declaration + $_ = " \x{123} " ; + + + \x%.*s will produce malformed UTF-8 character; use \x{%.*s} for that + use utf8 ; + $_ = "\xffe" + + 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 'octal' ; +chmod 3; +no warnings 'octal' ; +chmod 3; +EXPECT +chmod: mode argument is missing initial 0 at - line 3. +######## +# toke.c +use warnings 'syntax' ; +@a = qw(a, b, c) ; +no warnings 'syntax' ; +@a = qw(a, b, c) ; +EXPECT +Possible attempt to separate words with commas at - line 3. +######## +# toke.c +use warnings 'syntax' ; +@a = qw(a b #) ; +no warnings 'syntax' ; +@a = qw(a b #) ; +EXPECT +Possible attempt to put comments in qw() list at - line 3. +######## +# toke.c +use warnings 'octal' ; +umask 3; +no warnings 'octal' ; +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 'unsafe' ; +#line 25 "bar" +$a = FRED:: ; +no warnings 'unsafe' ; +#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 'utf8' ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE +EXPECT +Use of \x{} without utf8 declaration at foo line 30. +######## +# toke.c +no warnings 'utf8' ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE +EXPECT + +######## +# toke.c +use warnings 'utf8' ; +use utf8 ; +$_ = " \xffe " ; +no warnings 'utf8' ; +$_ = " \xffe " ; +EXPECT +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +######## +# 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 'ambiguous' ; + open FOO || time; + use warnings 'ambiguous' ; + 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 'unsafe' ; +my $a = "\m" ; +no warnings 'unsafe' ; +$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/t/pragma/warn/universal b/t/pragma/warn/universal new file mode 100644 index 0000000000..6dbb1be4e0 --- /dev/null +++ b/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/t/pragma/warn/utf8 b/t/pragma/warn/utf8 new file mode 100644 index 0000000000..b11514d826 --- /dev/null +++ b/t/pragma/warn/utf8 @@ -0,0 +1,56 @@ + + utf8.c AOK + + All Mandatory warnings + + [utf8_to_uv] + Malformed UTF-8 character + my $a = ord "\x80" ; + + Malformed UTF-8 character + my $a = ord "\xf080" ; + + [utf16_to_utf8] + Malformed UTF-16 surrogate + <<<<<< Add a test when somethig actually calls utf16_to_utf8 + +__END__ +# utf8.c [utf8_to_uv] +use utf8 ; +my $a = ord "\x80" ; +EXPECT +Malformed UTF-8 character at - line 3. +######## +# utf8.c [utf8_to_uv] +use utf8 ; +my $a = ord "\x80" ; +{ + use warnings 'utf8' ; + my $a = ord "\x80" ; + no warnings 'utf8' ; + my $a = ord "\x80" ; +} +EXPECT +Malformed UTF-8 character at - line 3. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 6. +Malformed UTF-8 character at - line 6. +######## +# utf8.c [utf8_to_uv] +use utf8 ; +my $a = ord "\xf080" ; +EXPECT +Malformed UTF-8 character at - line 3. +######## +# utf8.c [utf8_to_uv] +use utf8 ; +my $a = ord "\xf080" ; +{ + use warnings 'utf8' ; + my $a = ord "\xf080" ; + no warnings 'utf8' ; + my $a = ord "\xf080" ; +} +EXPECT +Malformed UTF-8 character at - line 3. +\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 6. +Malformed UTF-8 character at - line 6. diff --git a/t/pragma/warn/util b/t/pragma/warn/util new file mode 100644 index 0000000000..6c9bc8c696 --- /dev/null +++ b/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 "0777777777777777777777777777777777777777777777777" ; + 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 "0777777777777777777777777777777777777777777777777" ; +no warnings 'overflow' ; +$a = oct "0777777777777777777777777777777777777777777777777" ; +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/t/pragma/warning.t b/t/pragma/warnings.t index fa0301ea6a..73e4c8d1a8 100755..100644 --- a/t/pragma/warning.t +++ b/t/pragma/warnings.t @@ -2,13 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; + require Config; import Config; } $| = 1; -my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $tmpfile = "tmp0000"; my $i = 0 ; @@ -16,8 +17,16 @@ my $i = 0 ; END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; +my @w_files = () ; -foreach (sort glob("pragma/warn-*")) { +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)$/; @@ -43,7 +52,7 @@ for (@prgs){ my @temps = () ; if (s/^\s*-\w+//){ $switch = $&; - $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches + $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches } my($prog,$expected) = split(/\nEXPECT\n/, $_); if ( $prog =~ /--FILE--/) { @@ -70,19 +79,35 @@ for (@prgs){ `MCR $^X $switch $tmpfile` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $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; $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 and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ + 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"; |