diff options
Diffstat (limited to 'contrib/perl5/t')
350 files changed, 0 insertions, 51519 deletions
diff --git a/contrib/perl5/t/README b/contrib/perl5/t/README deleted file mode 100644 index 0953026..0000000 --- a/contrib/perl5/t/README +++ /dev/null @@ -1,16 +0,0 @@ -This is the perl test library. To run all the tests, just type 'TEST'. - -To add new tests, just look at the current tests and do likewise. - -If a test fails, run it by itself to see if it prints any informative -diagnostics. If not, modify the test to print informative diagnostics. -If you put out extra lines with a '#' character on the front, you don't -have to worry about removing the extra print statements later since TEST -ignores lines beginning with '#'. - -If you know that Perl is basically working but expect that some tests -will fail, you may want to use Test::Harness thusly: - ./perl -I../lib harness -This method pinpoints failed tests automatically. - -If you come up with new tests, please send them to perlbug@perl.org. diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST deleted file mode 100755 index bce9545..0000000 --- a/contrib/perl5/t/TEST +++ /dev/null @@ -1,185 +0,0 @@ -#!./perl - -# 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. - -$| = 1; - -if ($#ARGV >= 0 && $ARGV[0] eq '-v') { - $verbose = 1; - shift; -} - -chdir 't' if -f 't/TEST'; - -die "You need to run \"make test\" first to set things up.\n" - unless -e 'perl' or -e 'perl.exe'; - -# check leakage for embedders -$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; - -$ENV{EMXSHELL} = 'sh'; # For OS/2 - -if ($#ARGV == -1) { - @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); -} - -# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); - -_testprogs('perl', @ARGV); -_testprogs('compile', @ARGV) if (-e "../testcompile"); - -sub _testprogs { - $type = shift @_; - @tests = @_; - - - print <<'EOT' if ($type eq 'compile'); --------------------------------------------------------------------------------- -TESTING COMPILER --------------------------------------------------------------------------------- -EOT - - $ENV{PERLCC_TIMEOUT} = 120 - if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); - - $bad = 0; - $good = 0; - $total = @tests; - $files = 0; - $totmax = 0; - $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' ) { - print STDERR "$test creates infinite loop! Skipping.\n"; - next; - } - if ($test =~ /^$/) { - next; - } - $te = $test; - chop($te); - print "$te" . '.' x ($dotdotdot - length($te)); - - open(SCRIPT,"<$test") or die "Can't run $test.\n"; - $_ = <SCRIPT>; - close(SCRIPT); - if (/#!.*perl(.*)$/) { - $switch = $1; - if ($^O eq 'VMS') { - # Must protect uppercase switches with "" on command line - $switch =~ s/-([A-Z]\S*)/"-$1"/g; - } - } - else { - $switch = ''; - } - - if ($type eq 'perl') { - open(RESULTS,"./perl$switch $test |") or print "can't run.\n"; - } - else { - open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " - ." && ./$test.plc |") - or print "can't compile.\n"; - unlink "./$test.plc"; - } - - $ok = 0; - $next = 0; - while (<RESULTS>) { - if ($verbose) { - print $_; - } - unless (/^#/) { - if (/^1\.\.([0-9]+)/) { - $max = $1; - $totmax += $max; - $files += 1; - $next = 1; - $ok = 1; - } - else { - $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; - if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { - $next = $next + 1; - } - else { - $ok = 0; - } - } - } - } - close RESULTS; - $next = $next - 1; - if ($ok && $next == $max) { - if ($max) { - print "ok\n"; - $good = $good + 1; - } - else { - print "skipping test on this platform\n"; - $files -= 1; - } - } - else { - $next += 1; - print "FAILED at test $next\n"; - $bad = $bad + 1; - $_ = $test; - if (/^base/) { - die "Failed a basic test--cannot continue.\n"; - } - } - } - - if ($bad == 0) { - if ($ok) { - print "All tests successful.\n"; - # XXX add mention of 'perlbug -ok' ? - } - else { - die "FAILED--no tests were run for some reason.\n"; - } - } - else { - $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00"; - if ($bad == 1) { - warn "Failed 1 test script out of $files, $pct% okay.\n"; - } - else { - 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 - ### of them individually and examine any diagnostic messages they - ### produce. See the INSTALL document's section on "make test". - ### If you are testing the compiler, then ignore this message - ### and run - ### ./perl harness - ### in the directory ./t. -SHRDLU - warn <<'SHRDLU' if $good / $total > 0.8; - ### - ### Since most tests were successful, you have a good chance to - ### get information with better granularity by running - ### ./perl harness - ### in directory ./t. -SHRDLU - } - ($user,$sys,$cuser,$csys) = times; - print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", - $user,$sys,$cuser,$csys,$files,$totmax); -} -exit ($bad != 0); diff --git a/contrib/perl5/t/UTEST b/contrib/perl5/t/UTEST deleted file mode 100755 index 9c1dfc0..0000000 --- a/contrib/perl5/t/UTEST +++ /dev/null @@ -1,198 +0,0 @@ -#!./perl - -# Last change: Fri Jan 10 09:57:03 WET 1997 - -# This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. - -$| = 1; - -if ($#ARGV >= 0 && $ARGV[0] eq '-v') { - $verbose = 1; - shift; -} - -chdir 't' if -f 't/TEST'; - -die "You need to run \"make test\" first to set things up.\n" - unless -e 'perl' or -e 'perl.exe'; - -#$ENV{PERL_DESTRUCT_LEVEL} = '2'; -$ENV{EMXSHELL} = 'sh'; # For OS/2 - -if ($#ARGV == -1) { - @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); -} - -if ($^O eq 'os2' || $^O eq 'qnx') { - $sharpbang = 0; -} -else { - open(CONFIG, "../config.sh"); - while (<CONFIG>) { - if (/sharpbang='(.*)'/) { - $sharpbang = ($1 eq '#!'); - last; - } - } - close(CONFIG); -} - -%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); - -_testprogs('perl', @ARGV); -_testprogs('compile', @ARGV) if (-e "../testcompile"); - -sub _testprogs { - $type = shift @_; - @tests = @_; - - - print <<'EOT' if ($type eq 'compile'); --------------------------------------------------------------------------------- -TESTING COMPILER --------------------------------------------------------------------------------- -EOT - - $ENV{PERLCC_TIMEOUT} = 120 - if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); - - $bad = 0; - $good = 0; - $total = @tests; - $files = 0; - $totmax = 0; - while ($test = shift @tests) { - - if ( $infinite{$test} && $type eq 'compile' ) { - print STDERR "$test creates infinite loop! Skipping.\n"; - next; - } - if ($test =~ /^$/) { - next; - } - $te = $test; - chop($te); - print "$te" . '.' x (18 - length($te)); - if (0) { - -x $test || (print "isn't executable.\n"); - - if ($type eq 'perl') { - open(RESULTS, "./$test |") || (print "can't run.\n"); } - else { - open(RESULTS, "./perl -I../lib ../utils/perlcc -o ./$test.plc ./$test " - ." && ./$test.plc |") - or print "can't compile.\n"; - unlink "./$test.plc"; - } - } - else { - open(SCRIPT,"$test") or die "Can't run $test.\n"; - $_ = <SCRIPT>; - close(SCRIPT); - if (/#!..perl(.*)/) { - $switch = $1; - if ($^O eq 'VMS') { - # Must protect uppercase switches with "" on command line - $switch =~ s/-([A-Z]\S*)/"-$1"/g; - } - } - else { - $switch = ''; - } - - if ($type eq 'perl') { - open(RESULTS,"./perl$switch -I../lib -Mutf8 $test |") || (print "can't run.\n"); - } - else { - open(RESULTS, "./perl -I../lib ../utils/perlcc -Mutf8 ./$test -run -verbose dcf -log ../compilelog |") or print "can't compile.\n"; - } - } - $ok = 0; - $next = 0; - while (<RESULTS>) { - if ($verbose) { - print $_; - } - unless (/^#/) { - if (/^1\.\.([0-9]+)/) { - $max = $1; - $totmax += $max; - $files += 1; - $next = 1; - $ok = 1; - } - else { - $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; - if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { - $next = $next + 1; - } - else { - $ok = 0; - } - } - } - } - close RESULTS; - $next = $next - 1; - if ($ok && $next == $max) { - if ($max) { - print "ok\n"; - $good = $good + 1; - } - else { - print "skipping test on this platform\n"; - $files -= 1; - } - } - else { - $next += 1; - print "FAILED at test $next\n"; - $bad = $bad + 1; - $_ = $test; - if (/^base/) { - die "Failed a basic test--cannot continue.\n"; - } - } - } - - if ($bad == 0) { - if ($ok) { - print "All tests successful.\n"; - # XXX add mention of 'perlbug -ok' ? - } - else { - die "FAILED--no tests were run for some reason.\n"; - } - } - else { - $pct = sprintf("%.2f", $good / $total * 100); - if ($bad == 1) { - warn "Failed 1 test script out of $total, $pct% okay.\n"; - } - else { - warn "Failed $bad test scripts out of $total, $pct% okay.\n"; - } - warn <<'SHRDLU'; - ### Since not all tests were successful, you may want to run some - ### of them individually and examine any diagnostic messages they - ### produce. See the INSTALL document's section on "make test". - ### If you are testing the compiler, then ignore this message - ### and run - ### ./perl harness - ### in the directory ./t. -SHRDLU - warn <<'SHRDLU' if $good / $total > 0.8; - ### - ### Since most tests were successful, you have a good chance to - ### get information with better granularity by running - ### ./perl harness - ### in directory ./t. -SHRDLU - } - ($user,$sys,$cuser,$csys) = times; - print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", - $user,$sys,$cuser,$csys,$files,$totmax); -} -exit ($bad != 0); diff --git a/contrib/perl5/t/base/cond.t b/contrib/perl5/t/base/cond.t deleted file mode 100755 index 9a57348..0000000 --- a/contrib/perl5/t/base/cond.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:02 $ - -# make sure conditional operators work - -print "1..4\n"; - -$x = '0'; - -$x eq $x && (print "ok 1\n"); -$x ne $x && (print "not ok 1\n"); -$x eq $x || (print "not ok 2\n"); -$x ne $x || (print "ok 2\n"); - -$x == $x && (print "ok 3\n"); -$x != $x && (print "not ok 3\n"); -$x == $x || (print "not ok 4\n"); -$x != $x || (print "ok 4\n"); diff --git a/contrib/perl5/t/base/if.t b/contrib/perl5/t/base/if.t deleted file mode 100755 index 12db765..0000000 --- a/contrib/perl5/t/base/if.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -# $RCSfile: if.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:03 $ - -print "1..2\n"; - -# first test to see if we can run the tests. - -$x = 'test'; -if ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";} -if ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";} diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t deleted file mode 100755 index c7fb0e4..0000000 --- a/contrib/perl5/t/base/lex.t +++ /dev/null @@ -1,247 +0,0 @@ -#!./perl - -print "1..51\n"; - -$x = 'x'; - -print "#1 :$x: eq :x:\n"; -if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";} - -$x = $#; # this is the register $# - -if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";} - -$x = $#x; - -if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";} - -$x = '\\'; # '; - -if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";} - -eval 'while (0) { - print "foo\n"; -} -/^/ && (print "ok 5\n"); -'; - -eval '$foo{1} / 1;'; -if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";} - -eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;'; - -$foo = int($foo * 100 + .5); -if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";} - -print <<'EOF'; -ok 8 -EOF - -$foo = 'ok 9'; -print <<EOF; -$foo -EOF - -eval <<\EOE, print $@; -print <<'EOF'; -ok 10 -EOF - -$foo = 'ok 11'; -print <<EOF; -$foo -EOF -EOE - -print <<`EOS` . <<\EOF; -echo ok 12 -EOS -ok 13 -EOF - -print qq/ok 14\n/; -print qq(ok 15\n); - -print qq -[ok 16\n] -; - -print q<ok 17 ->; - -print <<; # Yow! -ok 18 - -# previous line intentionally left blank. - -print <<E1 eq "foo\n\n" ? "ok 19\n" : "not ok 19\n"; -@{[ <<E2 ]} -foo -E2 -E1 - -print <<E1 eq "foo\n\n" ? "ok 20\n" : "not ok 20\n"; -@{[ - <<E2 -foo -E2 -]} -E1 - -$foo = FOO; -$bar = BAR; -$foo{$bar} = BAZ; -$ary[0] = ABC; - -print "$foo{$bar}" eq "BAZ" ? "ok 21\n" : "not ok 21\n"; - -print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 22\n" : "not ok 22\n"; -print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n"; - -print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n"; -print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n"; -print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n"; - -# MJD 19980425 -($X, @X) = qw(a b c d); -print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n"; -print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n"; - -print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n"); - - -$foo = "not ok 30\n"; -$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++; -} - -# tests 47--51 start here -# tests for new array interpolation semantics: -# arrays now *always* interpolate into "..." strings. -# 20000522 MJD (mjd@plover.com) -{ - my $test = 47; - eval(q(">@nosuch<" eq "><")) || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # Look at this! This is going to be a common error in the future: - eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # Let's make sure that normal array interpolation still works right - # For some reason, this appears not to be tested anywhere else. - my @a = (1,2,3); - print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; - ++$test; - - # Ditto. - eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) - || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # This isn't actually a lex test, but it's testing the same feature - sub makearray { - my @array = ('fish', 'dog', 'carrot'); - *R::crackers = \@array; - } - - eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) - || print "# $@", "not "; - print "ok $test\n"; - ++$test; -} diff --git a/contrib/perl5/t/base/pat.t b/contrib/perl5/t/base/pat.t deleted file mode 100755 index c689f45..0000000 --- a/contrib/perl5/t/base/pat.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:05 $ - -print "1..2\n"; - -# first test to see if we can run the tests. - -$_ = 'test'; -if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";} -if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";} diff --git a/contrib/perl5/t/base/rs.t b/contrib/perl5/t/base/rs.t deleted file mode 100755 index e470f3a..0000000 --- a/contrib/perl5/t/base/rs.t +++ /dev/null @@ -1,132 +0,0 @@ -#!./perl -# Test $! - -print "1..14\n"; - -$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; - -# Create our test datafile -1 while unlink 'foo'; # in case junk left around -rmdir 'foo'; -open TESTFILE, ">./foo" or die "error $! $^E opening"; -binmode TESTFILE; -print TESTFILE $teststring; -close TESTFILE; - -open TESTFILE, "<./foo"; -binmode TESTFILE; - -# Check the default $/ -$bar = <TESTFILE>; -if ($bar eq "1\n") {print "ok 1\n";} else {print "not ok 1\n";} - -# explicitly set to \n -$/ = "\n"; -$bar = <TESTFILE>; -if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";} - -# Try a non line terminator -$/ = 3; -$bar = <TESTFILE>; -if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";} - -# Eat the line terminator -$/ = "\n"; -$bar = <TESTFILE>; - -# How about a larger terminator -$/ = "34"; -$bar = <TESTFILE>; -if ($bar eq "1234") {print "ok 4\n";} else {print "not ok 4\n";} - -# Eat the line terminator -$/ = "\n"; -$bar = <TESTFILE>; - -# Does paragraph mode work? -$/ = ''; -$bar = <TESTFILE>; -if ($bar eq "1234\n12345\n\n") {print "ok 5\n";} else {print "not ok 5\n";} - -# Try slurping the rest of the file -$/ = undef; -$bar = <TESTFILE>; -if ($bar eq "123456\n1234567\n") {print "ok 6\n";} else {print "not ok 6\n";} - -# try the record reading tests. New file so we don't have to worry about -# the size of \n. -close TESTFILE; -unlink "./foo"; -open TESTFILE, ">./foo"; -print TESTFILE "1234567890123456789012345678901234567890"; -binmode TESTFILE; -close TESTFILE; -open TESTFILE, "<./foo"; -binmode TESTFILE; - -# Test straight number -$/ = \2; -$bar = <TESTFILE>; -if ($bar eq "12") {print "ok 7\n";} else {print "not ok 7\n";} - -# Test stringified number -$/ = \"2"; -$bar = <TESTFILE>; -if ($bar eq "34") {print "ok 8\n";} else {print "not ok 8\n";} - -# Integer variable -$foo = 2; -$/ = \$foo; -$bar = <TESTFILE>; -if ($bar eq "56") {print "ok 9\n";} else {print "not ok 9\n";} - -# String variable -$foo = "2"; -$/ = \$foo; -$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 -if ($^O eq 'VMS') { - # Create a temp file. We jump through these hoops 'cause CREATE really - # doesn't like our methods for some reason. - open FDLFILE, "> ./foo.fdl"; - print FDLFILE "RECORD\n FORMAT VARIABLE\n"; - close FDLFILE; - open CREATEFILE, "> ./foo.com"; - print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n"; - print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n"; - print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n"; - print CREATEFILE '$ CLOSE YOW', "\n"; - print CREATEFILE "\$EXIT\n"; - close CREATEFILE; - $throwaway = `\@\[\]foo`, "\n"; - open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n"; - print TEMPFILE "foo\nfoobar\nbaz\n"; - close TEMPFILE; - - open TESTFILE, "<./foo.bar"; - $/ = \10; - $bar = <TESTFILE>; - if ($bar eq "foo\n") {print "ok 11\n";} else {print "not ok 11\n";} - $bar = <TESTFILE>; - if ($bar eq "foobar\n") {print "ok 12\n";} else {print "not ok 12\n";} - # can we do a short read? - $/ = \2; - $bar = <TESTFILE>; - if ($bar eq "ba") {print "ok 13\n";} else {print "not ok 13\n";} - # do we get the rest of the record? - $bar = <TESTFILE>; - if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";} - - 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 - foreach $test (11..14) {print "ok $test # skipped on non-VMS system\n"}; -} diff --git a/contrib/perl5/t/base/term.t b/contrib/perl5/t/base/term.t deleted file mode 100755 index 818eb71..0000000 --- a/contrib/perl5/t/base/term.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./perl - -# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -print "1..7\n"; - -# check "" interpretation - -$x = "\n"; -# 10 is ASCII/Iso Latin, 21 is EBCDIC. -if ($x eq chr(10) || - ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";} -else {print "not ok 1\n";} - -# check `` processing - -$x = `echo hi there`; -if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";} - -# check $#array - -$x[0] = 'foo'; -$x[1] = 'foo'; -$tmp = $#x; -print "#3\t:$tmp: == :1:\n"; -if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} - -# check numeric literal - -$x = 1; -if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} - -$x = '1E2'; -if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";} - -# check <> pseudoliteral - -open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null."); -if (<try> eq '') { - print "ok 6\n"; -} -else { - print "not ok 6\n"; - die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; -} - -open(try, "harness") || (die "Can't open harness."); -if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/contrib/perl5/t/cmd/elsif.t b/contrib/perl5/t/cmd/elsif.t deleted file mode 100755 index 7eace16..0000000 --- a/contrib/perl5/t/cmd/elsif.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -# $RCSfile: elsif.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:08 $ - -sub foo { - if ($_[0] == 1) { - 1; - } - elsif ($_[0] == 2) { - 2; - } - elsif ($_[0] == 3) { - 3; - } - else { - 4; - } -} - -print "1..4\n"; - -if (($x = &foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} -if (($x = &foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} -if (($x = &foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} -if (($x = &foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} diff --git a/contrib/perl5/t/cmd/for.t b/contrib/perl5/t/cmd/for.t deleted file mode 100755 index d70af57..0000000 --- a/contrib/perl5/t/cmd/for.t +++ /dev/null @@ -1,57 +0,0 @@ -#!./perl - -print "1..10\n"; - -for ($i = 0; $i <= 10; $i++) { - $x[$i] = $i; -} -$y = $x[10]; -print "#1 :$y: eq :10:\n"; -$y = join(' ', @x); -print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n"; -if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} - -$i = $c = 0; -for (;;) { - $c++; - last if $i++ > 10; -} -if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";} - -$foo = 3210; -@ary = (1,2,3,4,5); -foreach $foo (@ary) { - $foo *= 2; -} -if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";} - -for (@ary) { - s/(.*)/ok $1\n/; -} - -print $ary[1]; - -# test for internal scratch array generation -# this also tests that $foo was restored to 3210 after test 3 -for (split(' ','a b c d e')) { - $foo .= $_; -} -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/contrib/perl5/t/cmd/mod.t b/contrib/perl5/t/cmd/mod.t deleted file mode 100755 index e2ab777..0000000 --- a/contrib/perl5/t/cmd/mod.t +++ /dev/null @@ -1,54 +0,0 @@ -#!./perl - -# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $ - -print "1..12\n"; - -print "ok 1\n" if 1; -print "not ok 1\n" unless 1; - -print "ok 2\n" unless 0; -print "not ok 2\n" if 0; - -1 && (print "not ok 3\n") if 0; -1 && (print "ok 3\n") if 1; -0 || (print "not ok 4\n") if 0; -0 || (print "ok 4\n") if 1; - -$x = 0; -do {$x[$x] = $x;} while ($x++) < 10; -if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') { - print "ok 5\n"; -} else { - print "not ok 5 @x\n"; -} - -$x = 15; -$x = 10 while $x < 10; -if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";} - -$y[$_] = $_ * 2 foreach @x; -if (join(' ',@y) eq '0 2 4 6 8 10 12 14 16 18 20') { - print "ok 7\n"; -} else { - print "not ok 7 @y\n"; -} - -open(foo,'./TEST') || open(foo,'TEST') || open(foo,'t/TEST'); -$x = 0; -$x++ while <foo>; -print $x > 50 && $x < 1000 ? "ok 8\n" : "not ok 8\n"; - -$x = -0.5; -print "not " if scalar($x) < 0 and $x >= 0; -print "ok 9\n"; - -print "not " unless (-(-$x) < 0) == ($x < 0); -print "ok 10\n"; - -print "ok 11\n" if $x < 0; -print "not ok 11\n" unless $x < 0; - -print "ok 12\n" unless $x > 0; -print "not ok 12\n" if $x > 0; - diff --git a/contrib/perl5/t/cmd/subval.t b/contrib/perl5/t/cmd/subval.t deleted file mode 100755 index 3c60690..0000000 --- a/contrib/perl5/t/cmd/subval.t +++ /dev/null @@ -1,186 +0,0 @@ -#!./perl - -# $RCSfile: subval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:13 $ - -sub foo1 { - 'true1'; - if ($_[0]) { 'true2'; } -} - -sub foo2 { - 'true1'; - if ($_[0]) { return 'true2'; } else { return 'true3'; } - 'true0'; -} - -sub foo3 { - 'true1'; - unless ($_[0]) { 'true2'; } -} - -sub foo4 { - 'true1'; - unless ($_[0]) { 'true2'; } else { 'true3'; } -} - -sub foo5 { - 'true1'; - 'true2' if $_[0]; -} - -sub foo6 { - 'true1'; - 'true2' unless $_[0]; -} - -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";} -if (&foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";} -if (&foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";} - -if (&foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";} -if (&foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";} -if (&foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";} -if (&foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";} - -if (&foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";} -if (&foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";} -if (&foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";} -if (&foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";} - -# Now test to see that recursion works using a Fibonacci number generator - -sub fib { - my($arg) = @_; - my($foo); - $level++; - if ($arg <= 2) { - $foo = 1; - } - else { - $foo = &fib($arg-1) + &fib($arg-2); - } - $level--; - $foo; -} - -@good = (0,1,1,2,3,5,8,13,21,34,55,89); - -for ($i = 1; $i <= 10; $i++) { - $foo = $i + 12; - if (&fib($i) == $good[$i]) { - print "ok $foo\n"; - } - else { - print "not ok $foo\n"; - } -} - -sub ary1 { - (1,2,3); -} - -print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n"; - -print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n"; - -sub ary2 { - do { - return (1,2,3); - (3,2,1); - }; - 0; -} - -print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n"; - -$x = join(':',&ary2); -print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n"; - -sub somesub { - local($num,$P,$F,$L) = @_; - ($p,$f,$l) = caller; - print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n"; -} - -&somesub(27, 'main', __FILE__, __LINE__); - -package foo; -&main'somesub(28, 'foo', __FILE__, __LINE__); - -package main; -$i = 28; -open(FOO,">Cmd_subval.tmp"); -print FOO "blah blah\n"; -close FOO; - -&file_main(*F); -close F; -&info_main; - -&file_package(*F); -close F; -&info_package; - -unlink 'Cmd_subval.tmp'; - -sub file_main { - local(*F) = @_; - - open(F, 'Cmd_subval.tmp') || die "can't open\n"; - $i++; - eof F ? print "not ok $i\n" : print "ok $i\n"; -} - -sub info_main { - local(*F); - - open(F, 'Cmd_subval.tmp') || die "test: can't open\n"; - $i++; - eof F ? print "not ok $i\n" : print "ok $i\n"; - &iseof(*F); - close F; -} - -sub iseof { - local(*UNIQ) = @_; - - $i++; - eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n"; -} - -{package foo; - - sub main'file_package { - local(*F) = @_; - - open(F, 'Cmd_subval.tmp') || die "can't open\n"; - $main'i++; - eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; - } - - sub main'info_package { - local(*F); - - open(F, 'Cmd_subval.tmp') || die "can't open\n"; - $main'i++; - eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; - &iseof(*F); - } - - sub iseof { - local(*UNIQ) = @_; - - $main'i++; - 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/contrib/perl5/t/cmd/switch.t b/contrib/perl5/t/cmd/switch.t deleted file mode 100755 index faa5de4..0000000 --- a/contrib/perl5/t/cmd/switch.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -# $RCSfile: switch.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:14 $ - -print "1..18\n"; - -sub foo1 { - $_ = shift(@_); - $a = 0; - until ($a++) { - next if $_ eq 1; - next if $_ eq 2; - next if $_ eq 3; - next if $_ eq 4; - return 20; - } - continue { - return $_; - } -} - -print do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n"; -print do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n"; -print do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n"; -print do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n"; -print do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n"; -print do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n"; - -sub foo2 { - $_ = shift(@_); - { - last if $_ == 1; - last if $_ == 2; - last if $_ == 3; - last if $_ == 4; - } - continue { - return 20; - } - return $_; -} - -print do foo2(0) == 20 ? "ok 7\n" : "not ok 7\n"; -print do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n"; -print do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n"; -print do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n"; -print do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n"; -print do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n"; - -sub foo3 { - $_ = shift(@_); - if (/^1/) { - return 1; - } - elsif (/^2/) { - return 2; - } - elsif (/^3/) { - return 3; - } - elsif (/^4/) { - return 4; - } - else { - return 20; - } - return 40; -} - -print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n"; -print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n"; -print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n"; -print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n"; -print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n"; -print do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n"; diff --git a/contrib/perl5/t/cmd/while.t b/contrib/perl5/t/cmd/while.t deleted file mode 100755 index ecc15ed..0000000 --- a/contrib/perl5/t/cmd/while.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./perl - -print "1..22\n"; - -open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; -print tmp "tvi925\n"; -print tmp "tvi920\n"; -print tmp "vt100\n"; -print tmp "Amiga\n"; -print tmp "paper\n"; -close tmp; - -# test "last" command - -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -while (<fh>) { - last if /vt100/; -} -if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";} - -# test "next" command - -$bad = ''; -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -while (<fh>) { - next if /vt100/; - $bad = 1 if /vt100/; -} -if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";} - -# test "redo" command - -$bad = ''; -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -while (<fh>) { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} -if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";} - -# now do the same with a label and a continue block - -# test "last" command - -$badcont = ''; -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -line: while (<fh>) { - if (/vt100/) {last line;} -} continue { - $badcont = 1 if /vt100/; -} -if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";} -if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";} - -# test "next" command - -$bad = ''; -$badcont = 1; -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -entry: while (<fh>) { - next entry if /vt100/; - $bad = 1 if /vt100/; -} continue { - $badcont = '' if /vt100/; -} -if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";} -if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";} - -# test "redo" command - -$bad = ''; -$badcont = ''; -open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; -loop: while (<fh>) { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo loop; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} continue { - $badcont = 1 if /vt100/; -} -if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} -if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} - -close(fh) || die "Can't close Cmd_while.tmp."; -unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`; - -#$x = 0; -#while (1) { -# if ($x > 1) {last;} -# next; -#} continue { -# if ($x++ > 10) {last;} -# next; -#} -# -#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";} - -$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"; - -# check that scope cleanup happens right when there's a continue block -{ - my $var = 16; - while (my $i = ++$var) { - next if $i == 17; - last if $i > 17; - my $i = 0; - } - continue { - print "ok ", $var-1, "\nok $i\n"; - } -} - -{ - local $l = 18; - { - local $l = 0 - } - continue { - print "ok $l\n" - } -} - -{ - local $l = 19; - my $x = 0; - while (!$x++) { - local $l = 0 - } - continue { - print "ok $l\n" - } -} - -$i = 20; -{ - while (1) { - my $x; - print $x if defined $x; - $x = "not "; - print "ok $i\n"; ++$i; - if ($i == 21) { - next; - } - last; - } - continue { - print "ok $i\n"; ++$i; - } -} diff --git a/contrib/perl5/t/comp/bproto.t b/contrib/perl5/t/comp/bproto.t deleted file mode 100755 index 70748be..0000000 --- a/contrib/perl5/t/comp/bproto.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl -# -# check if builtins behave as prototyped -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..10\n"; - -my $i = 1; - -sub foo {} -my $bar = "bar"; - -sub test_too_many { - eval $_[0]; - print "not " unless $@ =~ /^Too many arguments/; - printf "ok %d\n",$i++; -} - -sub test_no_error { - eval $_[0]; - print "not " if $@; - printf "ok %d\n",$i++; -} - -test_too_many($_) for split /\n/, -q[ defined(&foo, $bar); - undef(&foo, $bar); - uc($bar,$bar); -]; - -test_no_error($_) for split /\n/, -q[ scalar(&foo,$bar); - defined &foo, &foo, &foo; - undef &foo, $bar; - uc $bar,$bar; - grep(not($bar), $bar); - grep(not($bar, $bar), $bar); - grep((not $bar, $bar, $bar), $bar); -]; diff --git a/contrib/perl5/t/comp/cmdopt.t b/contrib/perl5/t/comp/cmdopt.t deleted file mode 100755 index 3f701a4..0000000 --- a/contrib/perl5/t/comp/cmdopt.t +++ /dev/null @@ -1,90 +0,0 @@ -#!./perl - -# $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $ - -print "1..44\n"; - -# test the optimization of constants - -if (1) { print "ok 1\n";} else { print "not ok 1\n";} -unless (0) { print "ok 2\n";} else { print "not ok 2\n";} - -if (0) { print "not ok 3\n";} else { print "ok 3\n";} -unless (1) { print "not ok 4\n";} else { print "ok 4\n";} - -unless (!1) { print "ok 5\n";} else { print "not ok 5\n";} -if (!0) { print "ok 6\n";} else { print "not ok 6\n";} - -unless (!0) { print "not ok 7\n";} else { print "ok 7\n";} -if (!1) { print "not ok 8\n";} else { print "ok 8\n";} - -$x = 1; -if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";} -if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";} -$x = ''; -if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";} -if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";} - -$x = 1; -if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";} -if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";} -$x = ''; -if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";} -if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";} - - -# test the optimization of variables - -$x = 1; -if ($x) { print "ok 17\n";} else { print "not ok 17\n";} -unless ($x) { print "not ok 18\n";} else { print "ok 18\n";} - -$x = ''; -if ($x) { print "not ok 19\n";} else { print "ok 19\n";} -unless ($x) { print "ok 20\n";} else { print "not ok 20\n";} - -# test optimization of string operations - -$a = 'a'; -if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";} -if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";} - -if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";} -if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";} -# test interaction of logicals and other operations - -$a = 'a'; -$x = 1; -if ($a eq 'a' and $x) { print "ok 25\n";} else { print "not ok 25\n";} -if ($a ne 'a' and $x) { print "not ok 26\n";} else { print "ok 26\n";} -$x = ''; -if ($a eq 'a' and $x) { print "not ok 27\n";} else { print "ok 27\n";} -if ($a ne 'a' and $x) { print "not ok 28\n";} else { print "ok 28\n";} - -$x = 1; -if ($a eq 'a' or $x) { print "ok 29\n";} else { print "not ok 29\n";} -if ($a ne 'a' or $x) { print "ok 30\n";} else { print "not ok 30\n";} -$x = ''; -if ($a eq 'a' or $x) { print "ok 31\n";} else { print "not ok 31\n";} -if ($a ne 'a' or $x) { print "not ok 32\n";} else { print "ok 32\n";} - -$x = 1; -if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";} -if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} -$x = ''; -if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";} -if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";} - -$x = 1; -if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";} -if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} -$x = ''; -if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} -if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} - -$x = 1; -if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";} -if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";} -$x = ''; -if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";} -if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";} diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t deleted file mode 100755 index d2c64fe..0000000 --- a/contrib/perl5/t/comp/colon.t +++ /dev/null @@ -1,138 +0,0 @@ -#!./perl - -# -# Ensure that syntax using colons (:) is parsed correctly. -# The tests are done on the following tokens (by default): -# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm -# -- Robin Barker <rmb@cise.npl.co.uk> -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; - -$_ = ''; # to avoid undef warning on m// etc. - -sub ok { - my($test,$ok) = @_; - print "not " unless $ok; - print "ok $test\n"; -} - -$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings - -print "1..25\n"; - -ok 1, (eval "package ABC; sub zyx {1}; 1;" and - eval "ABC::zyx" and - not eval "ABC:: eq ABC||" and - not eval "ABC::: >= 0"); - -ok 2, (eval "package LABEL; sub zyx {1}; 1;" and - eval "LABEL::zyx" and - not eval "LABEL:: eq LABEL||" and - not eval "LABEL::: >= 0"); - -ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and - eval "XYZZY::zyx" and - not eval "XYZZY:: eq XYZZY||" and - not eval "XYZZY::: >= 0"); - -ok 4, (eval "package m; sub zyx {1}; 1;" and - not eval "m::zyx" and - eval "m:: eq m||" and - not eval "m::: >= 0"); - -ok 5, (eval "package q; sub zyx {1}; 1;" and - not eval "q::zyx" and - eval "q:: eq q||" and - not eval "q::: >= 0"); - -ok 6, (eval "package qq; sub zyx {1}; 1;" and - not eval "qq::zyx" and - eval "qq:: eq qq||" and - not eval "qq::: >= 0"); - -ok 7, (eval "package qw; sub zyx {1}; 1;" and - not eval "qw::zyx" and - eval "qw:: eq qw||" and - not eval "qw::: >= 0"); - -ok 8, (eval "package qx; sub zyx {1}; 1;" and - not eval "qx::zyx" and - eval "qx:: eq qx||" and - not eval "qx::: >= 0"); - -ok 9, (eval "package s; sub zyx {1}; 1;" and - not eval "s::zyx" and - not eval "s:: eq s||" and - eval "s::: >= 0"); - -ok 10, (eval "package tr; sub zyx {1}; 1;" and - not eval "tr::zyx" and - not eval "tr:: eq tr||" and - eval "tr::: >= 0"); - -ok 11, (eval "package y; sub zyx {1}; 1;" and - not eval "y::zyx" and - not eval "y:: eq y||" and - eval "y::: >= 0"); - -ok 12, (eval "ABC:1" and - not eval "ABC:echo: eq ABC|echo|" and - not eval "ABC:echo:ohce: >= 0"); - -ok 13, (eval "LABEL:1" and - not eval "LABEL:echo: eq LABEL|echo|" and - not eval "LABEL:echo:ohce: >= 0"); - -ok 14, (eval "XYZZY:1" and - not eval "XYZZY:echo: eq XYZZY|echo|" and - not eval "XYZZY:echo:ohce: >= 0"); - -ok 15, (not eval "m:1" and - eval "m:echo: eq m|echo|" and - not eval "m:echo:ohce: >= 0"); - -ok 16, (not eval "q:1" and - eval "q:echo: eq q|echo|" and - not eval "q:echo:ohce: >= 0"); - -ok 17, (not eval "qq:1" and - eval "qq:echo: eq qq|echo|" and - not eval "qq:echo:ohce: >= 0"); - -ok 18, (not eval "qw:1" and - eval "qw:echo: eq qw|echo|" and - not eval "qw:echo:ohce: >= 0"); - -ok 19, (not eval "qx:1" and - eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn - not eval "qx:echo:ohce: >= 0"); - -ok 20, (not eval "s:1" and - not eval "s:echo: eq s|echo|" and - eval "s:echo:ohce: >= 0"); - -ok 21, (not eval "tr:1" and - not eval "tr:echo: eq tr|echo|" and - eval "tr:echo:ohce: >= 0"); - -ok 22, (not eval "y:1" and - not eval "y:echo: eq y|echo|" and - eval "y:echo:ohce: >= 0"); - -ok 23, (eval "AUTOLOAD:1" and - not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and - not eval "AUTOLOAD:echo:ohce: >= 0"); - -ok 24, (eval "and:1" and - not eval "and:echo: eq and|echo|" and - not eval "and:echo:ohce: >= 0"); - -ok 25, (eval "alarm:1" and - not eval "alarm:echo: eq alarm|echo|" and - not eval "alarm:echo:ohce: >= 0"); diff --git a/contrib/perl5/t/comp/cpp.aux b/contrib/perl5/t/comp/cpp.aux deleted file mode 100755 index 536268a..0000000 --- a/contrib/perl5/t/comp/cpp.aux +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl -P - -print "1..3\n"; - -#define MESS "ok 1\n" -print MESS; - -#ifdef MESS - print "ok 2\n"; -#else - print "not ok 2\n"; -#endif - -open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file."; - -($prog = <<'END') =~ s/X//g; -X$ok = "not ok 3\n"; -X#include "Comp.cpp.inc" -X#ifdef OK -X$ok = OK; -X#endif -Xprint $ok; -END -print TRY $prog; -close TRY; - -open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file."); -print TRY '#define OK "ok 3\n"' . "\n"; -close TRY; - -$pwd=`pwd`; -$pwd =~ s/\n//; -$x = `./perl -P Comp.cpp.tmp`; -print $x; -unlink "Comp.cpp.tmp", "Comp.cpp.inc"; diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t deleted file mode 100755 index 5b061ee..0000000 --- a/contrib/perl5/t/comp/cpp.t +++ /dev/null @@ -1,18 +0,0 @@ -#!./perl - -# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; -if ( $^O eq 'MSWin32' or - ($Config{'cppstdin'} =~ /\bcppstdin\b/) and - ( ! -x $Config{'binexp'} . "/cppstdin") ) { - print "1..0 # Skip: \$Config{cppstdin} unavailable\n"; - exit; # Cannot test till after install, alas. -} - -system "./perl -P comp/cpp.aux" diff --git a/contrib/perl5/t/comp/decl.t b/contrib/perl5/t/comp/decl.t deleted file mode 100755 index 32b8509..0000000 --- a/contrib/perl5/t/comp/decl.t +++ /dev/null @@ -1,49 +0,0 @@ -#!./perl - -# $RCSfile: decl.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:19 $ - -# check to see if subroutine declarations work everwhere - -sub one { - print "ok 1\n"; -} -format one = -ok 5 -. - -print "1..7\n"; - -do one(); -do two(); - -sub two { - print "ok 2\n"; -} -format two = -@<<< -$foo -. - -if ($x eq $x) { - sub three { - print "ok 3\n"; - } - do three(); -} - -do four(); -$~ = 'one'; -write; -$~ = 'two'; -$foo = "ok 6"; -write; -$~ = 'three'; -write; - -format three = -ok 7 -. - -sub four { - print "ok 4\n"; -} diff --git a/contrib/perl5/t/comp/multiline.t b/contrib/perl5/t/comp/multiline.t deleted file mode 100755 index ed418b8..0000000 --- a/contrib/perl5/t/comp/multiline.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl - -# $RCSfile: multiline.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:20 $ - -print "1..5\n"; - -open(try,'>Comp.try') || (die "Can't open temp file."); - -$x = 'now is the time -for all good men -to come to. - - -! - -'; - -$y = 'now is the time' . "\n" . -'for all good men' . "\n" . -'to come to.' . "\n\n\n!\n\n"; - -if ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";} - -print try $x; -close try; - -open(try,'Comp.try') || (die "Can't reopen temp file."); -$count = 0; -$z = ''; -while (<try>) { - $z .= $_; - $count = $count + 1; -} - -if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";} - -if ($count == 7) {print "ok 3\n";} else {print "not ok 3\n";} - -$_ = ($^O eq 'MSWin32') ? `type Comp.try` : `cat Comp.try`; - -if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} - -close(try) || (die "Can't close temp file."); -unlink 'Comp.try' || `/bin/rm -f Comp.try`; - -if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/contrib/perl5/t/comp/package.t b/contrib/perl5/t/comp/package.t deleted file mode 100755 index 4982256..0000000 --- a/contrib/perl5/t/comp/package.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./perl - -print "1..8\n"; - -$blurfl = 123; -$foo = 3; - -package xyz; - -$bar = 4; - -{ - package ABC; - $blurfl = 5; - $main'a = $'b; -} - -$ABC'dyick = 6; - -$xyz = 2; - -$main = join(':', sort(keys %main::)); -$xyz = join(':', sort(keys %xyz::)); -$ABC = join(':', sort(keys %ABC::)); - -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"; - -package ABC; - -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/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t deleted file mode 100755 index 99dd3ea..0000000 --- a/contrib/perl5/t/comp/proto.t +++ /dev/null @@ -1,498 +0,0 @@ -#!./perl -# -# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> -# -# So far there are tests for the following prototypes. -# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) -# -# It is impossible to test every prototype that can be specified, but -# we should test as many as we can. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; - -print "1..122\n"; - -my $i = 1; - -sub testing (&$) { - my $p = prototype(shift); - my $c = shift; - my $what = defined $c ? '(' . $p . ')' : 'no prototype'; - print '#' x 25,"\n"; - print '# Testing ',$what,"\n"; - print '#' x 25,"\n"; - print "not " - if((defined($p) && defined($c) && $p ne $c) - || (defined($p) != defined($c))); - printf "ok %d\n",$i++; -} - -@_ = qw(a b c d); -my @array; -my %hash; - -## -## -## - -testing \&no_proto, undef; - -sub no_proto { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 0 == no_proto(); -printf "ok %d\n",$i++; - -print "not " unless 1 == no_proto(5); -printf "ok %d\n",$i++; - -print "not " unless 4 == &no_proto; -printf "ok %d\n",$i++; - -print "not " unless 1 == no_proto +6; -printf "ok %d\n",$i++; - -print "not " unless 4 == no_proto(@_); -printf "ok %d\n",$i++; - -## -## -## - - -testing \&no_args, ''; - -sub no_args () { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 0 == no_args(); -printf "ok %d\n",$i++; - -print "not " unless 0 == no_args; -printf "ok %d\n",$i++; - -print "not " unless 5 == no_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &no_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &no_args(1,2); -printf "ok %d\n",$i++; - -eval "no_args(1)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&one_args, '$'; - -sub one_args ($) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == one_args(1); -printf "ok %d\n",$i++; - -print "not " unless 1 == one_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &one_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &one_args(1,2); -printf "ok %d\n",$i++; - -eval "one_args(1,2)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -eval "one_args()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub one_a_args ($) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -one_a_args(@_); - -## -## -## - -testing \&over_one_args, '$@'; - -sub over_one_args ($@) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == over_one_args(1); -printf "ok %d\n",$i++; - -print "not " unless 2 == over_one_args(1,2); -printf "ok %d\n",$i++; - -print "not " unless 1 == over_one_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &over_one_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &over_one_args(1,2); -printf "ok %d\n",$i++; - -print "not " unless 5 == &over_one_args(1,@_); -printf "ok %d\n",$i++; - -eval "over_one_args()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub over_one_a_args ($@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -over_one_a_args(@_); -over_one_a_args(@_,1); -over_one_a_args(@_,1,2); -over_one_a_args(@_,@_); - -## -## -## - -testing \&scalar_and_hash, '$%'; - -sub scalar_and_hash ($%) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == scalar_and_hash(1); -printf "ok %d\n",$i++; - -print "not " unless 3 == scalar_and_hash(1,2,3); -printf "ok %d\n",$i++; - -print "not " unless 1 == scalar_and_hash +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &scalar_and_hash; -printf "ok %d\n",$i++; - -print "not " unless 2 == &scalar_and_hash(1,2); -printf "ok %d\n",$i++; - -print "not " unless 5 == &scalar_and_hash(1,@_); -printf "ok %d\n",$i++; - -eval "scalar_and_hash()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub scalar_and_hash_a ($@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -scalar_and_hash_a(@_); -scalar_and_hash_a(@_,1); -scalar_and_hash_a(@_,1,2); -scalar_and_hash_a(@_,@_); - -## -## -## - -testing \&one_or_two, '$;$'; - -sub one_or_two ($;$) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == one_or_two(1); -printf "ok %d\n",$i++; - -print "not " unless 2 == one_or_two(1,3); -printf "ok %d\n",$i++; - -print "not " unless 1 == one_or_two +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &one_or_two; -printf "ok %d\n",$i++; - -print "not " unless 3 == &one_or_two(1,2,3); -printf "ok %d\n",$i++; - -print "not " unless 5 == &one_or_two(1,@_); -printf "ok %d\n",$i++; - -eval "one_or_two()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -eval "one_or_two(1,2,3)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub one_or_two_a ($;$) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -one_or_two_a(@_); -one_or_two_a(@_,1); -one_or_two_a(@_,@_); - -## -## -## - -testing \&a_sub, '&'; - -sub a_sub (&) { - print "# \@_ = (",join(",",@_),")\n"; - &{$_[0]}; -} - -sub tmp_sub_1 { printf "ok %d\n",$i++ } - -a_sub { printf "ok %d\n",$i++ }; -a_sub \&tmp_sub_1; - -@array = ( \&tmp_sub_1 ); -eval 'a_sub @array'; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&a_subx, '\&'; - -sub a_subx (\&) { - print "# \@_ = (",join(",",@_),")\n"; - &{$_[0]}; -} - -sub tmp_sub_2 { printf "ok %d\n",$i++ } -a_subx &tmp_sub_2; - -@array = ( \&tmp_sub_2 ); -eval 'a_subx @array'; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&sub_aref, '&\@'; - -sub sub_aref (&\@) { - print "# \@_ = (",join(",",@_),")\n"; - my($sub,$array) = @_; - print "not " unless @_ == 2 && @{$array} == 4; - print map { &{$sub}($_) } @{$array} -} - -@array = (qw(O K)," ", $i++); -sub_aref { lc shift } @array; -print "\n"; - -## -## -## - -testing \&sub_array, '&@'; - -sub sub_array (&@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 5; - my $sub = shift; - print map { &{$sub}($_) } @_ -} - -@array = (qw(O K)," ", $i++); -sub_array { lc shift } @array; -print "\n"; - -## -## -## - -testing \&a_hash, '%'; - -sub a_hash (%) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_); -} - -print "not " unless 1 == a_hash 'a'; -printf "ok %d\n",$i++; - -print "not " unless 2 == a_hash 'a','b'; -printf "ok %d\n",$i++; - -## -## -## - -testing \&a_hash_ref, '\%'; - -sub a_hash_ref (\%) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless ref($_[0]) && $_[0]->{'a'}; - printf "ok %d\n",$i++; - $_[0]->{'b'} = 2; -} - -%hash = ( a => 1); -a_hash_ref %hash; -print "not " unless $hash{'b'} == 2; -printf "ok %d\n",$i++; - -## -## -## - -testing \&array_ref_plus, '\@@'; - -sub array_ref_plus (\@@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; - printf "ok %d\n",$i++; - @{$_[0]} = (qw(ok)," ",$i++,"\n"); -} - -@array = ('a'); -{ my @more = ('x'); - array_ref_plus @array, @more; } -print "not " unless @array == 4; -print @array; - -my $p; -print "not " if defined prototype('CORE::print'); -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 "ok ", $i++, "\n"; - -print "# CORE:Foo => ($p), \$@ => `$@'\nnot " - 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 '$', -# a possible regression. - -sub foo1 ($\@); -eval q{ foo1 "s" }; -print "not " unless $@ =~ /^Not enough/; -print "ok ", $i++, "\n"; - -sub foo2 ($\%); -eval q{ foo2 "s" }; -print "not " unless $@ =~ /^Not enough/; -print "ok ", $i++, "\n"; - -sub X::foo3; -*X::foo3 = sub {'ok'}; -print "# $@not " unless eval {X->foo3} eq 'ok'; -print "ok ", $i++, "\n"; - -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++; -} - -# test prototypes when they are evaled and there is a syntax error -# -for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { - no warnings 'redefine'; - my $eval = "sub evaled_subroutine $p { &void *; }"; - eval $eval; - # The /Syntax error/ is seen on OS/390. It's /syntax error/ elsewhere - print "# eval[$eval]\nnot " unless $@ && $@ =~ /[Ss]yntax error/; - print "ok ", $i++, "\n"; -} diff --git a/contrib/perl5/t/comp/redef.t b/contrib/perl5/t/comp/redef.t deleted file mode 100755 index 07e978b..0000000 --- a/contrib/perl5/t/comp/redef.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl -w -# -# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> - -BEGIN { - $warn = ""; - $SIG{__WARN__} = sub { $warn .= join("",@_) } -} - -sub ok ($$) { - print $_[1] ? "ok " : "not ok ", $_[0], "\n"; -} - -print "1..18\n"; - -my $NEWPROTO = 'Prototype mismatch:'; - -sub sub0 { 1 } -sub sub0 { 2 } - -ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s; - -sub sub1 { 1 } -sub sub1 () { 2 } - -ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1 vs ()\E[^\n]+\n//s; -ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s; - -sub sub2 { 1 } -sub sub2 ($) { 2 } - -ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2 vs ($)\E[^\n]+\n//s; -ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s; - -sub sub3 () { 1 } -sub sub3 { 2 } - -ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s; -ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s; - -sub sub4 () { 1 } -sub sub4 () { 2 } - -ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s; - -sub sub5 () { 1 } -sub sub5 ($) { 2 } - -ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s; -ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s; - -sub sub6 ($) { 1 } -sub sub6 { 2 } - -ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s; -ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s; - -sub sub7 ($) { 1 } -sub sub7 () { 2 } - -ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s; -ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s; - -sub sub8 ($) { 1 } -sub sub8 ($) { 2 } - -ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s; - -sub sub9 ($@) { 1 } -sub sub9 ($) { 2 } - -ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; -ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; - -ok 18, $_ eq ''; - -# If we got any errors that we were not expecting, then print them -print $_ if length $_; - - diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t deleted file mode 100755 index 1b0af9f..0000000 --- a/contrib/perl5/t/comp/require.t +++ /dev/null @@ -1,156 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -# don't make this lexical -$i = 1; -# Tests 21 .. 23 work only with non broken UTF16-as-code implementations, -# i.e. not EBCDIC Perls. -my $Is_EBCDIC = ord('A') == 193 ? 1 : 0; -if ($Is_EBCDIC) { - print "1..20\n"; -} -else { - print "1..23\n"; -} - -sub do_require { - %INC = (); - 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': $!"; - binmode REQ; - use bytes; - print REQ @_; - close REQ; -} - -eval {require 5.005}; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 5.005 }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 5.005; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { - require 5.005 -}; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# new style version numbers - -eval { require v5.5.630; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 10.0.2; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; -print "ok ",$i++,"\n"; - -eval q{ use v5.5.630; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval q{ use 10.0.2; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; -print "ok ",$i++,"\n"; - -my $ver = 5.005_63; -eval { require $ver; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# check inaccurate fp -$ver = 10.2; -eval { require $ver; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.200\.0 required/; -print "ok ",$i++,"\n"; - -$ver = 10.000_02; -eval { require $ver; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; -print "ok ",$i++,"\n"; - -print "not " unless 5.5.1 gt v5.5; -print "ok ",$i++,"\n"; - -{ - use utf8; - print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; - print "ok ",$i++,"\n"; - - print "not " unless v7.15 eq "\x{7}\x{f}"; - print "ok ",$i++,"\n"; - - print "not " - unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; - print "ok ",$i++,"\n"; -} - -# interaction with pod (see the eof) -write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); -require "bleah.pm"; -$i++; - -# run-time failure in require -do_require "0;\n"; -print "# $@\nnot " unless $@ =~ /did not return a true/; -print "ok ",$i++,"\n"; - -# compile-time failure in require -do_require "1)\n"; -# 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 -do_require "1"; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# do FILE shouldn't see any outside lexicals -my $x = "ok $i\n"; -write_file("bleah.do", <<EOT); -\$x = "not ok $i\\n"; -EOT -do "bleah.do"; -dofile(); -sub dofile { do "bleah.do"; }; -print $x; - -exit if $Is_EBCDIC; - -# UTF-encoded things -my $utf8 = chr(0xFEFF); - -$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n)); - -sub bytes_to_utf16 { - my $utf16 = pack("$_[0]*", unpack("C*", $_[1])); - return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; -} - -$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE -$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE - -END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; } - -# ***interaction with pod (don't put any thing after here)*** - -=pod diff --git a/contrib/perl5/t/comp/script.t b/contrib/perl5/t/comp/script.t deleted file mode 100755 index a9bc47d..0000000 --- a/contrib/perl5/t/comp/script.t +++ /dev/null @@ -1,24 +0,0 @@ -#!./perl - -# $RCSfile: script.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:23 $ - -print "1..3\n"; - -$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$x = `$PERL -le "print 'ok';"`; - -if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} - -open(try,">Comp.script") || (die "Can't open temp file."); -print try 'print "ok\n";'; print try "\n"; -close try; - -$x = `$PERL Comp.script`; - -if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} - -$x = `$PERL <Comp.script`; - -if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} - -unlink 'Comp.script' || `/bin/rm -f Comp.script`; diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t deleted file mode 100755 index f079eef..0000000 --- a/contrib/perl5/t/comp/term.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl - -# tests that aren't important enough for base.term - -print "1..23\n"; - -$x = "\\n"; -print "#1\t:$x: eq " . ':\n:' . "\n"; -if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";} - -$x = "#2\t:$x: eq :\\n:\n"; -print $x; -unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";} - -if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";} - -$one = 'a'; - -if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";} -if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";} -if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";} -if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";} -if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";} -if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";} -if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";} - -if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";} - -@foo = (1,2,3); -if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";} -if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";} -$" = '::'; -if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";} - -# test if C<eval "{...}"> distinguishes between blocks and hashrefs - -$a = "{ '\\'' , 'foo' }"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";} - -$a = "{ '\\\\\\'abc' => 'foo' }"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";} - -$a = "{'a\\\n\\'b','foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";} - -$a = "{'\\\\\\'\\\\'=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";} - -$a = "{q,a'b,,'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";} - -$a = "{q[[']]=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";} - -# needs disambiguation if first term is a variable -$a = "+{ \$a , 'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} - -$a = "+{ \$a=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} - -$a = "{ 0x01 => 'foo'}->{0x01}"; -$a = eval $a; -if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t deleted file mode 100755 index fb59777..0000000 --- a/contrib/perl5/t/comp/use.t +++ /dev/null @@ -1,170 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..27\n"; - -my $i = 1; -eval "use 5.000"; # implicit semicolon -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -eval "use 5.000;"; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -eval sprintf "use %.5f;", $]; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - - -eval sprintf "use %.5f;", $] - 0.000001; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -eval sprintf("use %.5f;", $] + 1); -unless ($@) { - print "not "; -} -print "ok ",$i++,"\n"; - -eval sprintf "use %.5f;", $] + 0.00001; -unless ($@) { - print "not "; -} -print "ok ",$i++,"\n"; - - -{ use lib } # check that subparse saves pending tokens - -local $lib::VERSION = 1.0; - -eval "use lib 0.9"; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -eval "use lib 1.0"; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -eval "use lib 1.01"; -unless ($@) { - print "not "; -} -print "ok ",$i++,"\n"; - - -eval "use lib 0.9 qw(fred)"; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -print "not " unless $INC[0] eq "fred"; -print "ok ",$i++,"\n"; - -eval "use lib 1.0 qw(joe)"; -if ($@) { - print STDERR $@,"\n"; - print "not "; -} -print "ok ",$i++,"\n"; - -print "not " unless $INC[0] eq "joe"; -print "ok ",$i++,"\n"; - -eval "use lib 1.01 qw(freda)"; -unless ($@) { - print "not "; -} -print "ok ",$i++,"\n"; - -print "not " if $INC[0] eq "freda"; -print "ok ",$i++,"\n"; - -{ - local $lib::VERSION = 35.36; - eval "use lib v33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib v100.105"; - unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) { - print "not "; - } - print "ok ",$i++,"\n"; - - eval "use lib 33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib 100.105"; - unless ($@ =~ /lib version 100\.105 required--this is only version 35\.3/) { - print "not "; - } - print "ok ",$i++,"\n"; - - local $lib::VERSION = '35.36'; - eval "use lib v33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib v100.105"; - unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { - print "not "; - } - print "ok ",$i++,"\n"; - - eval "use lib 33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib 100.105"; - unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { - print "not "; - } - print "ok ",$i++,"\n"; - - local $lib::VERSION = v35.36; - eval "use lib v33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib v100.105"; - unless ($@ =~ /lib v100\.105 required--this is only v35\.36/) { - print "not "; - } - print "ok ",$i++,"\n"; - - eval "use lib 33.55"; - print "not " if $@; - print "ok ",$i++,"\n"; - - eval "use lib 100.105"; - unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) { - print "not "; - } - print "ok ",$i++,"\n"; -} diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness deleted file mode 100644 index c24d46f..0000000 --- a/contrib/perl5/t/harness +++ /dev/null @@ -1,81 +0,0 @@ -#!./perl - -# We suppose that perl _mostly_ works at this moment, so may use -# sophisticated testing. - -BEGIN { - chdir 't' if -d 't'; - 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::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 = 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"; - -$ENV{'HARNESS_COMPILE_TEST'} = 1; -$ENV{'PERLCC_TIMEOUT'} = 120 unless $ENV{'PERLCC_TIMEOUT'}; - -Test::Harness::runtests @tests; -foreach (keys %datahandle) { - unlink "$_.t"; -} diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t deleted file mode 100755 index 2b8f23b..0000000 --- a/contrib/perl5/t/io/argv.t +++ /dev/null @@ -1,127 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..21\n"; - -use File::Spec; - -my $devnull = File::Spec->devnull; - -open(try, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); -print try "a line\n"; -close try; - -if ($^O eq 'MSWin32') { - $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`; -} -else { - $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`; -} -if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} - -if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`; -} -else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`; -} -if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} - -if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" |.\\perl -e "while (<>) {print \$_;}"`; -} -else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}'`; -} -if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} - -@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); -while (<>) { - $y .= $. . $_; - if (eof()) { - if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";} - } -} - -if ($y eq "1a line\n2a line\n3a line\n") - {print "ok 5\n";} -else - {print "not ok 5\n";} - -open(try, '>Io_argv1.tmp') or die "Can't open temp file: $!"; -close try; -open(try, '>Io_argv2.tmp') or die "Can't open temp file: $!"; -close try; -@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); -$^I = '.bak'; -$/ = undef; -my $i = 6; -while (<>) { - s/^/ok $i\n/; - ++$i; - print; -} -open(try, '<Io_argv1.tmp') or die "Can't open temp file: $!"; -print while <try>; -open(try, '<Io_argv2.tmp') or die "Can't open temp file: $!"; -print while <try>; -close try; -undef $^I; - -eof try or print 'not '; -print "ok 8\n"; - -eof NEVEROPENED or print 'not '; -print "ok 9\n"; - -open STDIN, 'Io_argv1.tmp' or die $!; -@ARGV = (); -!eof() or print 'not '; -print "ok 10\n"; - -<> eq "ok 6\n" or print 'not '; -print "ok 11\n"; - -open STDIN, $devnull or die $!; -@ARGV = (); -eof() or print 'not '; -print "ok 12\n"; - -@ARGV = ('Io_argv1.tmp'); -!eof() or print 'not '; -print "ok 13\n"; - -@ARGV = ($devnull, $devnull); -!eof() or print 'not '; -print "ok 14\n"; - -close ARGV or die $!; -eof() or print 'not '; -print "ok 15\n"; - -{ - local $/; - open F, 'Io_argv1.tmp' or die; - <F>; # set $. = 1 - print "not " if defined(<F>); # should hit eof - print "ok 16\n"; - open F, $devnull or die; - print "not " unless defined(<F>); - print "ok 17\n"; - print "not " if defined(<F>); - print "ok 18\n"; - print "not " if defined(<F>); - print "ok 19\n"; - open F, $devnull or die; # restart cycle again - print "not " unless defined(<F>); - print "ok 20\n"; - print "not " if defined(<F>); - print "ok 21\n"; - close F; -} - -END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp.bak', 'Io_argv2.tmp', 'Io_argv2.tmp.bak' } diff --git a/contrib/perl5/t/io/dup.t b/contrib/perl5/t/io/dup.t deleted file mode 100755 index af13d4d..0000000 --- a/contrib/perl5/t/io/dup.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -# $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $ - -print "1..6\n"; - -print "ok 1\n"; - -open(dupout,">&STDOUT"); -open(duperr,">&STDERR"); - -open(STDOUT,">Io.dup") || die "Can't open stdout"; -open(STDERR,">&STDOUT") || die "Can't open stderr"; - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print STDOUT "ok 2\n"; -print STDERR "ok 3\n"; -if ($^O eq 'MSWin32') { - print `echo ok 4`; - print `echo ok 5 1>&2`; # does this work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} - -close(STDOUT); -close(STDERR); - -open(STDOUT,">&dupout"); -open(STDERR,">&duperr"); - -if ($^O eq 'MSWin32') { print `type Io.dup` } -else { system 'cat Io.dup' } -unlink 'Io.dup'; - -print STDOUT "ok 6\n"; - diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t deleted file mode 100755 index 8170b33..0000000 --- a/contrib/perl5/t/io/fs.t +++ /dev/null @@ -1,210 +0,0 @@ -#!./perl - -# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or - $^O eq 'os2' or $^O eq 'mint'); - -if (defined &Win32::IsWinNT && Win32::IsWinNT()) { - $Is_Dosish = '' if Win32::FsType() eq 'NTFS'; -} - -print "1..29\n"; - -$wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); -chop($wd); - -if ($^O eq 'MSWin32') { `rmdir /s /q tmp 2>nul`; `mkdir tmp`; } -else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } -chdir './tmp'; -`/bin/rm -rf a b c x` if -x '/bin/rm'; - -umask(022); - -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 ($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 ($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} || $Is_Dosish) - {print "ok 4 # skipped: no link\n";} -elsif ($nlink == 3) - {print "ok 4\n";} -else {print "not ok 4\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";} - -$newmode = $^O eq 'MSWin32' ? 0444 : 0777; -if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('c'); -if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} -elsif (($mode & 0777) == $newmode) {print "ok 7\n";} -else {print "not ok 7\n";} - -$newmode = 0700; -if ($^O eq 'MSWin32') { - chmod 0444, 'x'; - $newmode = 0666; -} - -if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} -elsif ((chmod $newmode,'c','x') == 2) {print "ok 8\n";} -else {print "not ok 8\n";} - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('c'); -if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} -elsif (($mode & 0777) == $newmode) {print "ok 9\n";} -else {print "not ok 9\n";} - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('x'); -if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} -elsif (($mode & 0777) == $newmode) {print "ok 10\n";} -else {print "not ok 10\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";} -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('x'); -if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";} - -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";} -$delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem -chmod 0777, 'b'; -$foo = (utime 500000000,500000000 + $delta,'b'); -if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('b'); -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";} -elsif ($^O =~ /\blinux\b/i) { - # Maybe stat() cannot get the correct atime, as happens via NFS on linux? - $foo = (utime 400000000,500000000 + 2*$delta,'b'); - my ($new_atime, $new_mtime) = (stat('b'))[8,9]; - if ($new_atime == $atime && $new_mtime - $mtime == $delta) - {print "ok 18 # accounted for possible NFS/glibc2.2 bug on linux\n";} - else - {print "not ok 18 $atime/$new_atime $mtime/$new_mtime\n";} -} else - {print "not ok 18 $atime $mtime\n";} - -if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";} -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('b'); -if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} -unlink 'c'; - -chdir $wd || die "Can't cd back to $wd"; - -unlink 'c'; -if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { - # we have symbolic links - system("cp TEST TEST$$"); - # we have to copy because e.g. GNU grep gets huffy if we have - # a symlink forest to another disk (it complains about too many - # levels of symbolic links, even if we have only two) - if (symlink("TEST$$","c")) {print "ok 21\n";} else {print "not ok 21\n";} - $foo = `grep perl c 2>&1`; - if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} - unlink 'c'; - unlink("TEST$$"); -} -else { - print "ok 21\nok 22\n"; -} - -# truncate (may not be implemented everywhere) -unlink "Iofs.tmp"; -`echo helloworld > Iofs.tmp`; -eval { truncate "Iofs.tmp", 5; }; -if ($@ =~ /not implemented/) { - print "# truncate not implemented -- skipping tests 23 through 26\n"; - for (23 .. 26) { - print "ok $_\n"; - } -} -else { - if (-s "Iofs.tmp" == 5) {print "ok 23\n"} else {print "not ok 23\n"} - truncate "Iofs.tmp", 0; - if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"} - open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; - binmode FH; - { select FH; $| = 1; select STDOUT } - { - use strict; - print FH "x\n" x 200; - truncate(FH, 200) or die "Can't truncate FH: $!"; - } - if ($^O eq 'dos' - # Not needed on HPFS, but needed on HPFS386 ?! - or $^O eq 'os2') - { - close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; - } - if (-s "Iofs.tmp" == 200) {print "ok 25\n"} else {print "not ok 25\n"} - truncate FH, 0; - if ($^O eq 'dos' - # Not needed on HPFS, but needed on HPFS386 ?! - or $^O eq 'os2') - { - close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; - } - if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} - close FH; -} - -# check if rename() can be used to just change case of filename -chdir './tmp'; -open(fh,'>x') || die "Can't create x"; -close(fh); -rename('x', 'X'); -print 'not ' unless -e 'X'; -print "ok 27\n"; -unlink 'X'; -chdir $wd || die "Can't cd back to $wd"; - -# check if rename() works on directories -rename 'tmp', 'tmp1' or print "not "; -print "ok 28\n"; --d 'tmp1' or print "not "; -print "ok 29\n"; - -END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/contrib/perl5/t/io/inplace.t b/contrib/perl5/t/io/inplace.t deleted file mode 100755 index ff410a7..0000000 --- a/contrib/perl5/t/io/inplace.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -$^I = $^O eq 'VMS' ? '_bak' : '.bak'; - -# $RCSfile: inplace.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:29 $ - -print "1..2\n"; - -@ARGV = ('.a','.b','.c'); -if ($^O eq 'MSWin32') { - $CAT = '.\perl -e "print<>"'; - `.\\perl -le "print 'foo'" > .a`; - `.\\perl -le "print 'foo'" > .b`; - `.\\perl -le "print 'foo'" > .c`; -} -elsif ($^O eq 'VMS') { - $CAT = 'MCR []perl. -e "print<>"'; - `MCR []perl. -le "print 'foo'" > ./.a`; - `MCR []perl. -le "print 'foo'" > ./.b`; - `MCR []perl. -le "print 'foo'" > ./.c`; -} -else { - $CAT = 'cat'; - `echo foo | tee .a .b .c`; -} -while (<>) { - s/foo/bar/; -} -continue { - print; -} - -if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";} -if (`$CAT .a$^I .b$^I .c$^I` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} - -unlink '.a', '.b', '.c', ".a$^I", ".b$^I", ".c$^I"; diff --git a/contrib/perl5/t/io/iprefix.t b/contrib/perl5/t/io/iprefix.t deleted file mode 100755 index 10a5c5f..0000000 --- a/contrib/perl5/t/io/iprefix.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -$^I = 'bak*'; - -# Modified from the original inplace.t to test adding prefixes - -print "1..2\n"; - -@ARGV = ('.a','.b','.c'); -if ($^O eq 'MSWin32') { - $CAT = '.\perl -e "print<>"'; - `.\\perl -le "print 'foo'" > .a`; - `.\\perl -le "print 'foo'" > .b`; - `.\\perl -le "print 'foo'" > .c`; -} -elsif ($^O eq 'VMS') { - $CAT = 'MCR []perl. -e "print<>"'; - `MCR []perl. -le "print 'foo'" > ./.a`; - `MCR []perl. -le "print 'foo'" > ./.b`; - `MCR []perl. -le "print 'foo'" > ./.c`; -} -else { - $CAT = 'cat'; - `echo foo | tee .a .b .c`; -} -while (<>) { - s/foo/bar/; -} -continue { - print; -} - -if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";} -if (`$CAT bak.a bak.b bak.c` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} - -unlink '.a', '.b', '.c', 'bak.a', 'bak.b', 'bak.c'; diff --git a/contrib/perl5/t/io/nargv.t b/contrib/perl5/t/io/nargv.t deleted file mode 100755 index fb13857..0000000 --- a/contrib/perl5/t/io/nargv.t +++ /dev/null @@ -1,63 +0,0 @@ -#!./perl - -print "1..5\n"; - -my $j = 1; -for $i ( 1,2,5,4,3 ) { - $file = mkfiles($i); - open(FH, "> $file") || die "can't create $file: $!"; - print FH "not ok " . $j++ . "\n"; - close(FH) || die "Can't close $file: $!"; -} - - -{ - local *ARGV; - local $^I = '.bak'; - local $_; - @ARGV = mkfiles(1..3); - $n = 0; - while (<>) { - print STDOUT "# initial \@ARGV: [@ARGV]\n"; - if ($n++ == 2) { - other(); - } - show(); - } -} - -$^I = undef; -@ARGV = mkfiles(1..3); -$n = 0; -while (<>) { - print STDOUT "#final \@ARGV: [@ARGV]\n"; - if ($n++ == 2) { - other(); - } - show(); -} - -sub show { - #warn "$ARGV: $_"; - s/^not //; - print; -} - -sub other { - print STDOUT "# Calling other\n"; - local *ARGV; - local *ARGVOUT; - local $_; - @ARGV = mkfiles(5, 4); - while (<>) { - print STDOUT "# inner \@ARGV: [@ARGV]\n"; - show(); - } -} - -sub mkfiles { - my @files = map { "scratch$_" } @_; - return wantarray ? @files : $files[-1]; -} - -END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/contrib/perl5/t/io/open.t b/contrib/perl5/t/io/open.t deleted file mode 100755 index 0e2d57c..0000000 --- a/contrib/perl5/t/io/open.t +++ /dev/null @@ -1,291 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# $RCSfile$ -$| = 1; -use warnings; -$Is_VMS = $^O eq 'VMS'; -$Is_Dos = $^O eq 'dos'; - -print "1..66\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - -# my $file tests - -# 1..9 -{ - unlink("afile") if -f "afile"; - print "$!\nnot " unless open(my $f,"+>afile"); - ok; - binmode $f; - print "not " unless -f "afile"; - ok; - print "not " unless print $f "SomeData\n"; - ok; - print "not " unless tell($f) == 9; - ok; - print "not " unless seek($f,0,0); - ok; - $b = <$f>; - print "not " unless $b eq "SomeData\n"; - ok; - print "not " unless -f $f; - ok; - eval { die "Message" }; - # warn $@; - print "not " unless $@ =~ /<\$f> line 1/; - ok; - print "not " unless close($f); - ok; - unlink("afile"); -} - -# 10..12 -{ - print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); - ok; - print $f "a row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' < 10; - ok; -} - -# 13..15 -{ - print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); - ok; - print $f "a row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' > 10; - ok; -} - -# 16..18 -{ - print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - print "not " unless close($f); - ok; -} - -# 19..23 -{ - print "not " unless -s 'afile' < 20; - ok; - print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - seek $f, 0, 1; - print $f "yet another row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' > 20; - ok; - - unlink("afile"); -} - -# 24..26 -if ($Is_VMS) { - for (24..26) { print "ok $_ # skipped: not Unix fork\n"; $test++;} -} -else { - print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); - ./perl -e "print qq(a row\n); print qq(another row\n)" -EOC - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - print "not " unless close($f); - ok; -} - -# 27..30 -if ($Is_VMS) { - for (27..30) { print "ok $_ # skipped: not Unix fork\n"; $test++;} -} -else { - print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); - ./perl -pe "s/^not //" -EOC - ok; - @rows = <$f>; - print $f "not ok $test\n"; $test++; - print $f "not ok $test\n"; $test++; - print "#\nnot " unless close($f); - sleep 1; - ok; -} - -# 31..32 -eval <<'EOE' and print "not "; -open my $f, '<&', 'afile'; -1; -EOE -ok; -$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; -ok; - -# local $file tests - -# 33..41 -{ - unlink("afile") if -f "afile"; - print "$!\nnot " unless open(local $f,"+>afile"); - ok; - binmode $f; - print "not " unless -f "afile"; - ok; - print "not " unless print $f "SomeData\n"; - ok; - print "not " unless tell($f) == 9; - ok; - print "not " unless seek($f,0,0); - ok; - $b = <$f>; - print "not " unless $b eq "SomeData\n"; - ok; - print "not " unless -f $f; - ok; - eval { die "Message" }; - # warn $@; - print "not " unless $@ =~ /<\$f> line 1/; - ok; - print "not " unless close($f); - ok; - unlink("afile"); -} - -# 42..44 -{ - print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile'); - ok; - print $f "a row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' < 10; - ok; -} - -# 45..47 -{ - print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile'); - ok; - print $f "a row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' > 10; - ok; -} - -# 48..50 -{ - print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile'); - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - print "not " unless close($f); - ok; -} - -# 51..55 -{ - print "not " unless -s 'afile' < 20; - ok; - print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile'); - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - seek $f, 0, 1; - print $f "yet another row\n"; - print "not " unless close($f); - ok; - print "not " unless -s 'afile' > 20; - ok; - - unlink("afile"); -} - -# 56..58 -if ($Is_VMS) { - for (56..58) { print "ok $_ # skipped: not Unix fork\n"; $test++;} -} -else { - print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); - ./perl -e "print qq(a row\n); print qq(another row\n)" -EOC - ok; - @rows = <$f>; - print "not " unless @rows == 2; - ok; - print "not " unless close($f); - ok; -} - -# 59..62 -if ($Is_VMS) { - for (59..62) { print "ok $_ # skipped: not Unix fork\n"; $test++;} -} -else { - print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); - ./perl -pe "s/^not //" -EOC - ok; - @rows = <$f>; - print $f "not ok $test\n"; $test++; - print $f "not ok $test\n"; $test++; - print "#\nnot " unless close($f); - sleep 1; - ok; -} - -# 63..64 -eval <<'EOE' and print "not "; -open local $f, '<&', 'afile'; -1; -EOE -ok; -$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; -ok; - -# 65..66 -{ - local *F; - for (1..2) { - if ($Is_Dos) { - open(F, "echo \\#foo|") or print "not "; - } else { - open(F, "echo #foo|") or print "not "; - } - print <F>; - close F; - } - ok; - for (1..2) { - if ($Is_Dos) { - open(F, "-|", "echo \\#foo") or print "not "; - } else { - open(F, "-|", "echo #foo") or print "not "; - } - print <F>; - close F; - } - ok; -} diff --git a/contrib/perl5/t/io/openpid.t b/contrib/perl5/t/io/openpid.t deleted file mode 100755 index 7c04a29..0000000 --- a/contrib/perl5/t/io/openpid.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./perl - -##################################################################### -# -# Test for process id return value from open -# Ronald Schmidt (The Software Path) RonaldWS@software-path.com -# -##################################################################### - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - if ($^O eq 'dos') { - print "1..0 # Skip: no multitasking\n"; - exit 0; - } -} - -use Config; -$| = 1; -$SIG{PIPE} = 'IGNORE'; - -print "1..10\n"; - -$perl = qq[$^X "-I../lib"]; - -# -# commands run 4 perl programs. Two of these programs write a -# short message to STDOUT and exit. Two of these programs -# read from STDIN. One reader never exits and must be killed. -# the other reader reads one line, waits a few seconds and then -# exits to test the waitpid function. -# -$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; -$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; -$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN -$cmd4 = qq/$perl -e "print scalar <>;"/; - -#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 -select(FH4); $| = 1; select(STDOUT); - -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/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t deleted file mode 100755 index 96935e3..0000000 --- a/contrib/perl5/t/io/pipe.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - unless ($Config{'d_fork'}) { - print "1..0 # Skip: no fork\n"; - exit 0; - } -} - -$| = 1; -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 ($^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'; - } - - pipe(READER,WRITER) || die "Can't open pipe"; - - 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'; - } -} -wait; # Collect from $pid - -pipe(READER,WRITER) || die "Can't open pipe"; -close READER; - -$SIG{'PIPE'} = 'broken_pipe'; - -sub broken_pipe { - $SIG{'PIPE'} = 'IGNORE'; # loop preventer - print "ok 7\n"; -} - -print WRITER "not ok 7\n"; -close WRITER; -sleep 1; -print "ok 8\n"; - -# VMS doesn't like spawning subprocesses that are still connected to -# STDOUT. Someone should modify tests #9 to #12 to work with VMS. - -if ($^O eq 'VMS') { - 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' || $^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. - # Nor does POSIX-BC. - print "ok 9 # skipped\n"; -} -else { - local $SIG{PIPE} = 'IGNORE'; - open NIL, '|true' or die "open failed: $!"; - sleep 5; - print NIL 'foo' or die "print failed: $!"; - if (close NIL) { - print "not ok 9\n"; - } - else { - print "ok 9\n"; - } -} - -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; -if (close NIL) { - print "not ok 10\n# successful close\n"; -} -elsif ($! != 0) { - print "not ok 10\n# errno $!\n"; -} -elsif ($? == 0) { - print "not ok 10\n# status 0\n"; -} -else { - print "ok 10\n"; -} - -if ($^O eq 'mpeix') { - print "ok 11 # skipped\n"; - print "ok 12 # skipped\n"; -} else { - # check that status for the correct process is collected - my $zombie = fork or exit 37; - my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; - $SIG{ALRM} = sub { return }; - alarm(1); - my $close = close FH; - if ($? == 13*256 && ! length $close && ! $!) { - print "ok 11\n"; - } else { - print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; - }; - my $wait = wait; - if ($? == 37*256 && $wait == $zombie && ! $!) { - print "ok 12\n"; - } else { - print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; - } -} - -# Test new semantics for missing command in piped open -# 19990114 M-J. Dominus mjd@plover.com -{ local *P; - print (((open P, "| " ) ? "not " : ""), "ok 13\n"); - print (((open P, " |" ) ? "not " : ""), "ok 14\n"); -} - -# check that status is unaffected by implicit close -{ - local(*NIL); - open NIL, '|exit 23;' or die "fork failed: $!"; - $? = 42; - # NIL implicitly closed here -} -if ($? != 42) { - print "# status $?, expected 42\nnot "; -} -print "ok 15\n"; -$? = 0; diff --git a/contrib/perl5/t/io/print.t b/contrib/perl5/t/io/print.t deleted file mode 100755 index 0578ee6..0000000 --- a/contrib/perl5/t/io/print.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -print "1..18\n"; - -$foo = 'STDOUT'; -print $foo "ok 1\n"; - -print "ok 2\n","ok 3\n","ok 4\n"; -print STDOUT "ok 5\n"; - -open(foo,">-"); -print foo "ok 6\n"; - -printf "ok %d\n",7; -printf("ok %d\n",8); - -@a = ("ok %d%c",9,ord("\n")); -printf @a; - -$a[1] = 10; -printf STDOUT @a; - -$, = ' '; -$\ = "\n"; - -print "ok","11"; - -@x = ("ok","12\nok","13\nok"); -@y = ("15\nok","16"); -print @x,"14\nok",@y; -{ - local $\ = "ok 17\n# null =>[\000]\nok 18\n"; - print ""; -} diff --git a/contrib/perl5/t/io/read.t b/contrib/perl5/t/io/read.t deleted file mode 100755 index b27fde1..0000000 --- a/contrib/perl5/t/io/read.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -# $RCSfile$ - -print "1..1\n"; - -open(A,"+>a"); -print A "_"; -seek(A,0,0); - -$b = "abcd"; -$b = ""; - -read(A,$b,1,4); - -close(A); - -unlink("a"); - -if ($b eq "\000\000\000\000_") { - print "ok 1\n"; -} else { # Probably "\000bcd_" - print "not ok 1\n"; -} - -unlink 'a'; diff --git a/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t deleted file mode 100755 index c840c92..0000000 --- a/contrib/perl5/t/io/tell.t +++ /dev/null @@ -1,94 +0,0 @@ -#!./perl - -# $RCSfile: tell.t,v $$Revision$$Date$ - -print "1..23\n"; - -$TST = 'tst'; - -$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or - $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin'); - -open($TST, 'harness') || (die "Can't open harness"); -binmode $TST if $Is_Dosish; -if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } - -$firstline = <$TST>; -$secondpos = tell; - -$x = 0; -while (<tst>) { - if (eof) {$x++;} -} -if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } - -$lastpos = tell; - -unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } - -if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } - -if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } - -if ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } - -if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } - -if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } - -if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; } - -if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } - -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, 'harness') || (die "Can't open harness: $!"); -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"; } -} - -close(other); -if (tell(other) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; } - -if (tell(ether) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; } - -# ftell(STDIN) (or any std streams) is undefined, it can return -1 or -# something else. ftell() on pipes, fifos, and sockets is defined to -# return -1. - diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t deleted file mode 100755 index fb5a984..0000000 --- a/contrib/perl5/t/lib/abbrev.t +++ /dev/null @@ -1,51 +0,0 @@ -#!./perl - -print "1..7\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Abbrev; - -print "ok 1\n"; - -# old style as reference -local(%x); -my @z = qw(list edit send abort gripe listen); -abbrev(*x, @z); -my $r = join ':', sort keys %x; -print "not " if exists $x{'l'} || - exists $x{'li'} || - exists $x{'lis'}; -print "ok 2\n"; - -print "not " unless $x{'list'} eq 'list' && - $x{'liste'} eq 'listen' && - $x{'listen'} eq 'listen'; -print "ok 3\n"; - -print "not " unless $x{'a'} eq 'abort' && - $x{'ab'} eq 'abort' && - $x{'abo'} eq 'abort' && - $x{'abor'} eq 'abort' && - $x{'abort'} eq 'abort'; -print "ok 4\n"; - -my $test = 5; - -# wantarray -my %y = abbrev @z; -my $s = join ':', sort keys %y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; - -my $y = abbrev @z; -$s = join ':', sort keys %$y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; - -%y = (); -abbrev \%y, @z; - -$s = join ':', sort keys %y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t deleted file mode 100755 index f38e905..0000000 --- a/contrib/perl5/t/lib/ansicolor.t +++ /dev/null @@ -1,81 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Test suite for the Term::ANSIColor Perl module. Before `make install' is -# performed this script should be runnable with `make test'. After `make -# install' it should work as `perl test.pl'. - -############################################################################ -# Ensure module can be loaded -############################################################################ - -BEGIN { $| = 1; print "1..8\n" } -END { print "not ok 1\n" unless $loaded } -use Term::ANSIColor qw(:constants color colored); -$loaded = 1; -print "ok 1\n"; - - -############################################################################ -# Test suite -############################################################################ - -# Test simple color attributes. -if (color ('blue on_green', 'bold') eq "\e[34;42;1m") { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} - -# Test colored. -if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") { - print "ok 3\n"; -} else { - print "not ok 3\n"; -} - -# Test the constants. -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") { - print "ok 4\n"; -} else { - print "not ok 4\n"; -} - -# Test AUTORESET. -$Term::ANSIColor::AUTORESET = 1; -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") { - print "ok 5\n"; -} else { - print "not ok 5\n"; -} - -# Test EACHLINE. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored ("test\n\ntest", 'bold') - eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") { - print "ok 6\n"; -} else { - print colored ("test\n\ntest", 'bold'), "\n"; - print "not ok 6\n"; -} - -# Test EACHLINE with multiple trailing delimiters. -$Term::ANSIColor::EACHLINE = "\r\n"; -if (colored ("test\ntest\r\r\n\r\n", 'bold') - eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") { - print "ok 7\n"; -} else { - print "not ok 7\n"; -} - -# Test the array ref form. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored (['bold', 'on_green'], "test\n", "\n", "test") - eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { - print "ok 8\n"; -} else { - print colored (['bold', 'on_green'], "test\n", "\n", "test"); - print "not ok 8\n"; -} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t deleted file mode 100755 index 40c4366..0000000 --- a/contrib/perl5/t/lib/anydbm.t +++ /dev/null @@ -1,155 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ - print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; - exit 0; - } -} -require AnyDBM_File; -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); -print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) - ? "ok 1\n" : "not ok 1\n"); - -$Dfile = "Op_dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op_dbmx*>; -} -if ($Is_Dosish) { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -while (($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -@keys = keys(%h); -@values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -$ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -@foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -if ($h{''} eq 'bar') { - print "ok 12\n" ; -} -else { - if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) { - ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ; - $major =~ s/^0+// ; - $minor =~ s/^0+// ; - $patch =~ s/^0+// ; - $compact = "$major.$minor.$patch" ; - # - # anydbm.t test 12 will fail when AnyDBM_File uses the combination of - # DB_File and Berkeley DB 2.4.10 (or greater). - # You are using DB_File $DB_File::VERSION and Berkeley DB $compact - # - # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. - # This feature will be reenabled in a future version of Berkeley DB. - # - print "ok 12 # skipped: db v$compact, no null key support\n" ; - } - else { - print "not ok 12\n" ; - } -} - -untie %h; -if ($^O eq 'VMS') { - unlink 'Op_dbmx.sdbm_dir', $Dfile; -} else { - unlink 'Op_dbmx.dir', $Dfile; -} diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t deleted file mode 100755 index 440122c..0000000 --- a/contrib/perl5/t/lib/attrs.t +++ /dev/null @@ -1,138 +0,0 @@ -#!./perl - -# Regression tests for attrs.pm and the C<sub x : attrs> syntax. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - eval 'require attrs; 1' or do { - print "1..0\n"; - exit 0; - } -} - -sub NTESTS () ; - -my $test, $ntests; -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; - -eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t2 { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my @attrs = attrs::get($anon3 ? $anon3 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e1 ($) : plugh ;'; -unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e4 ($) : plugh + xyzzy ;'; -unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -{ - my $w = "" ; - local $SIG{__WARN__} = sub {$w = @_[0]} ; - eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; - (print "not "), $failed=1 if $@; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} - (print "not "), $failed=1 - if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} -} - - -# Other tests should be added above this line - -sub NTESTS () { $ntests } - -exit $failed; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t deleted file mode 100755 index b53b9fe..0000000 --- a/contrib/perl5/t/lib/autoloader.t +++ /dev/null @@ -1,122 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - $dir = "auto-$$"; - @INC = $dir; - push @INC, '../lib'; -} - -print "1..11\n"; - -# First we must set up some autoloader files -mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; -mkdir "$dir/auto", 0755 or die "Can't mkdir: $!"; -mkdir "$dir/auto/Foo", 0755 or die "Can't mkdir: $!"; - -open(FOO, ">$dir/auto/Foo/foo.al") or die; -print FOO <<'EOT'; -package Foo; -sub foo { shift; shift || "foo" } -1; -EOT -close(FOO); - -open(BAR, ">$dir/auto/Foo/bar.al") or die; -print BAR <<'EOT'; -package Foo; -sub bar { shift; shift || "bar" } -1; -EOT -close(BAR); - -open(BAZ, ">$dir/auto/Foo/bazmarkhian.al") or die; -print BAZ <<'EOT'; -package Foo; -sub bazmarkhianish { shift; shift || "baz" } -1; -EOT -close(BAZ); - -# Let's define the package -package Foo; -require AutoLoader; -@ISA=qw(AutoLoader); - -sub new { bless {}, shift }; - -package main; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # autoloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -print "not " unless $@ =~ /^Can't locate/; -print "ok 3\n"; - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -print "not " unless $@ =~ /oops/; -print "ok 4\n"; - -# Pass regular expression variable to autoloaded function. This used -# to go wrong because AutoLoader used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# test recursive autoloads -open(F, ">$dir/auto/Foo/a.al") or die; -print F <<'EOT'; -package Foo; -BEGIN { b() } -sub a { print "ok 11\n"; } -1; -EOT -close(F); - -open(F, ">$dir/auto/Foo/b.al") or die; -print F <<'EOT'; -package Foo; -sub b { print "ok 10\n"; } -1; -EOT -close(F); -Foo::a(); - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir/auto/Foo/foo.al"; -unlink "$dir/auto/Foo/bar.al"; -unlink "$dir/auto/Foo/bazmarkhian.al"; -unlink "$dir/auto/Foo/a.al"; -unlink "$dir/auto/Foo/b.al"; -rmdir "$dir/auto/Foo"; -rmdir "$dir/auto"; -rmdir "$dir"; -} diff --git a/contrib/perl5/t/lib/b.t b/contrib/perl5/t/lib/b.t deleted file mode 100755 index 22156c2..0000000 --- a/contrib/perl5/t/lib/b.t +++ /dev/null @@ -1,163 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..15\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - -use B::Deparse; -my $deparse = B::Deparse->new() or print "not "; -ok; - -print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1}); -ok; - -print "not " if "{\n '???';\n 2;\n}" ne - $deparse->coderef2text(sub {1;2}); -ok; - -print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne - $deparse->coderef2text(sub {++$test and $test/=2;}); -ok; -{ -my $a = <<'EOF'; -{ - $test = sub : lvalue { - my $x; - } - ; -} -EOF -chomp $a; -print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a; -ok; - -$a =~ s/lvalue/method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a; -ok; - -$a =~ s/method/locked method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}}) - ne $a; -ok; -} - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; - -$a = `$^X $path "-MO=Deparse" -anle 1 $redir`; -$a =~ s/-e syntax OK\n//g; -$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 -$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' -$b = <<'EOF'; - -LINE: while (defined($_ = <ARGV>)) { - chomp $_; - @F = split(/\s+/, $_, 0); - '???'; -} - -EOF -print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; -ok; - -#6 -$a = `$^X $path "-MO=Debug" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; -ok; - -#7 -$a = `$^X $path "-MO=Terse" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; -ok; - -$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`; -$a =~ s/\(0x[^)]+\)//g; -$a =~ s/\[[^\]]+\]//g; -$a =~ s/-e syntax OK//; -$a =~ s/[^a-z ]+//g; -$a =~ s/\s+/ /g; -$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; -$a =~ s/^\s+//; -$a =~ s/\s+$//; -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; -if ($is_thread) { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -threadsv readline gv lineseq nextstate aassign null pushmark split pushre -threadsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} else { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -null gvsv readline gv lineseq nextstate aassign null pushmark split pushre -null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} -$b=~s/\n/ /g;$b=~s/\s+/ /g; -$b =~ s/\s+$//; -print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b; -ok; - -chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); -$a = join ',', sort split /,/, $a; -$a =~ s/-uWin32,// if $^O eq 'MSWin32'; -$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; -$a =~ s/-uCwd,// if $^O eq 'cygwin'; -if ($Config{static_ext} eq ' ') { - $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; - if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) - $b = join ',', sort split /,/, $b; - } - print "# [$a] vs [$b]\nnot " if $a ne $b; - ok; -} else { - print "ok $test # skipped: one or more static extensions\n"; $test++; -} - -if ($is_thread) { - print "# use5005threads: test $test skipped\n"; -} else { - $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`; - if (ord('A') != 193) { # ASCIIish - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; - } - else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205"> - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s; - } -} -ok; - -# Bug 20001204.07 -{ -my $foo = $deparse->coderef2text(sub { { 234; }}); -# Constants don't get optimised here. -print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; -ok; -$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); -print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; -ok; -} diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t deleted file mode 100755 index 9bee1bf..0000000 --- a/contrib/perl5/t/lib/basename.t +++ /dev/null @@ -1,144 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Basename qw(fileparse basename dirname); - -print "1..41\n"; - -# import correctly? -print +(defined(&basename) && !defined(&fileparse_set_fstype) ? - '' : 'not '),"ok 1\n"; - -# set fstype -- should replace non-null default -print +(length(File::Basename::fileparse_set_fstype('unix')) ? - '' : 'not '),"ok 2\n"; - -# Unix syntax tests -($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') { - print "ok 3\n"; -} -else { - print "not ok 3 |$base|$path|$type|\n"; -} -print +(basename('/arma/virumque.cano') eq 'virumque.cano' ? - '' : 'not '),"ok 4\n"; -print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n"; -print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n"; - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ? - '' : 'not '),"ok 8\n"; - -# VMS syntax tests -($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') { - print "ok 9\n"; -} -else { - print "not ok 9 |$base|$path|$type|\n"; -} -print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 10\n"; -print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ? - '' : 'not '),"ok 11\n"; -print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ? - '' : 'not '),"ok 12\n"; -print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n"; -$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; -print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n"; - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ? - '' : 'not '),"ok 16\n"; - -# MSDOS syntax tests -($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') { - print "ok 17\n"; -} -else { - print "not ok 17 |$base|$path|$type|\n"; -} -print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 18\n"; -print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ? - '' : 'not '),"ok 19\n"; -print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n"; -print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n"; - -# Yes "/" is a legal path separator under MSDOS -basename("lib/File/Basename.pm") eq "Basename.pm" or print "not "; -print "ok 22\n"; - - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ? - '' : 'not '),"ok 23\n"; - -# MacOS syntax tests -($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') { - print "ok 24\n"; -} -else { - print "not ok 24 |$base|$path|$type|\n"; -} -print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 25\n"; -print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? - '' : 'not '),"ok 26\n"; -print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; -print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; -print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; -print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; -print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; -print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; -print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; - - -# Check quoting of metacharacters in suffix arg by basename() -print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 34\n"; -print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 35\n"; - -# extra tests for a few specific bugs - -File::Basename::fileparse_set_fstype 'MSDOS'; -# perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; -# perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; - -File::Basename::fileparse_set_fstype 'UNIX'; -# perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; -# perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; - -# The empty tainted value, for tainting strings -my $TAINT = substr($^X, 0, 0); -# How to identify taint when you see it -sub any_tainted (@) { - not eval { join("",@_), kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} -sub all_tainted (@) { - for (@_) { return 0 unless tainted $_ } - 1; -} - -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; -print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 41\n"; diff --git a/contrib/perl5/t/lib/bigfloat.t b/contrib/perl5/t/lib/bigfloat.t deleted file mode 100755 index 8e0a0ef..0000000 --- a/contrib/perl5/t/lib/bigfloat.t +++ /dev/null @@ -1,408 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigfloat.pl"; - -$test = 0; -$| = 1; -print "1..355\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } elsif (/^\$.*/) { - eval "$_;"; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0E+0 -+0:+0E+0 -+00:+0E+0 -+0 0 0:+0E+0 -000000 0000000 00000:+0E+0 --0:+0E+0 --0000:+0E+0 -+1:+1E+0 -+01:+1E+0 -+001:+1E+0 -+00000100000:+1E+5 -123456789:+123456789E+0 --1:-1E+0 --01:-1E+0 --001:-1E+0 --123456789:-123456789E+0 --00000100000:-1E+5 -123.456a:NaN -123.456:+123456E-3 -0.01:+1E-2 -.002:+2E-3 --0.0003:-3E-4 --.0000000004:-4E-10 -123456E2:+123456E+2 -123456E-2:+123456E-2 --123456E2:-123456E+2 --123456E-2:-123456E-2 -1e1:+1E+1 -2e-11:+2E-11 --3e111:-3E+111 --4e-1111:-4E-1111 -&fneg -abd:NaN -+0:+0E+0 -+1:-1E+0 --1:+1E+0 -+123456789:-123456789E+0 --123456789:+123456789E+0 -+123.456789:-123456789E-6 --123456.789:+123456789E-3 -&fabs -abc:NaN -+0:+0E+0 -+1:+1E+0 --1:+1E+0 -+123456789:+123456789E+0 --123456789:+123456789E+0 -+123.456789:+123456789E-6 --123456.789:+123456789E-3 -&fround -$bigfloat::rnd_mode = 'trunc' -+10123456789:5:+10123E+6 --10123456789:5:-10123E+6 -+10123456789:9:+101234567E+2 --10123456789:9:-101234567E+2 -+101234500:6:+101234E+3 --101234500:6:-101234E+3 -$bigfloat::rnd_mode = 'zero' -+20123456789:5:+20123E+6 --20123456789:5:-20123E+6 -+20123456789:9:+201234568E+2 --20123456789:9:-201234568E+2 -+201234500:6:+201234E+3 --201234500:6:-201234E+3 -$bigfloat::rnd_mode = '+inf' -+30123456789:5:+30123E+6 --30123456789:5:-30123E+6 -+30123456789:9:+301234568E+2 --30123456789:9:-301234568E+2 -+301234500:6:+301235E+3 --301234500:6:-301234E+3 -$bigfloat::rnd_mode = '-inf' -+40123456789:5:+40123E+6 --40123456789:5:-40123E+6 -+40123456789:9:+401234568E+2 --40123456789:9:-401234568E+2 -+401234500:6:+401234E+3 --401234500:6:-401235E+3 -$bigfloat::rnd_mode = 'odd' -+50123456789:5:+50123E+6 --50123456789:5:-50123E+6 -+50123456789:9:+501234568E+2 --50123456789:9:-501234568E+2 -+501234500:6:+501235E+3 --501234500:6:-501235E+3 -$bigfloat::rnd_mode = 'even' -+60123456789:5:+60123E+6 --60123456789:5:-60123E+6 -+60123456789:9:+601234568E+2 --60123456789:9:-601234568E+2 -+601234500:6:+601234E+3 --601234500:6:-601234E+3 -&ffround -$bigfloat::rnd_mode = 'trunc' -+1.23:-1:+12E-1 --1.23:-1:-12E-1 -+1.27:-1:+12E-1 --1.27:-1:-12E-1 -+1.25:-1:+12E-1 --1.25:-1:-12E-1 -+1.35:-1:+13E-1 --1.35:-1:-13E-1 --0.006:-1:+0E+0 --0.006:-2:+0E+0 -$bigfloat::rnd_mode = 'zero' -+2.23:-1:+22E-1 --2.23:-1:-22E-1 -+2.27:-1:+23E-1 --2.27:-1:-23E-1 -+2.25:-1:+22E-1 --2.25:-1:-22E-1 -+2.35:-1:+23E-1 --2.35:-1:-23E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '+inf' -+3.23:-1:+32E-1 --3.23:-1:-32E-1 -+3.27:-1:+33E-1 --3.27:-1:-33E-1 -+3.25:-1:+33E-1 --3.25:-1:-32E-1 -+3.35:-1:+34E-1 --3.35:-1:-33E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '-inf' -+4.23:-1:+42E-1 --4.23:-1:-42E-1 -+4.27:-1:+43E-1 --4.27:-1:-43E-1 -+4.25:-1:+42E-1 --4.25:-1:-43E-1 -+4.35:-1:+43E-1 --4.35:-1:-44E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'odd' -+5.23:-1:+52E-1 --5.23:-1:-52E-1 -+5.27:-1:+53E-1 --5.27:-1:-53E-1 -+5.25:-1:+53E-1 --5.25:-1:-53E-1 -+5.35:-1:+53E-1 --5.35:-1:-53E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'even' -+6.23:-1:+62E-1 --6.23:-1:-62E-1 -+6.27:-1:+63E-1 --6.27:-1:-63E-1 -+6.25:-1:+62E-1 --6.25:-1:-62E-1 -+6.35:-1:+64E-1 --6.35:-1:-64E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:+1E+0 -+1:+1:+2E+0 --1:+0:-1E+0 -+0:-1:-1E+0 --1:-1:-2E+0 --1:+1:+0E+0 -+1:-1:+0E+0 -+9:+1:+1E+1 -+99:+1:+1E+2 -+999:+1:+1E+3 -+9999:+1:+1E+4 -+99999:+1:+1E+5 -+999999:+1:+1E+6 -+9999999:+1:+1E+7 -+99999999:+1:+1E+8 -+999999999:+1:+1E+9 -+9999999999:+1:+1E+10 -+99999999999:+1:+1E+11 -+10:-1:+9E+0 -+100:-1:+99E+0 -+1000:-1:+999E+0 -+10000:-1:+9999E+0 -+100000:-1:+99999E+0 -+1000000:-1:+999999E+0 -+10000000:-1:+9999999E+0 -+100000000:-1:+99999999E+0 -+1000000000:-1:+999999999E+0 -+10000000000:-1:+9999999999E+0 -+123456789:+987654321:+111111111E+1 --123456789:+987654321:+864197532E+0 --123456789:-987654321:-111111111E+1 -+123456789:-987654321:-864197532E+0 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:-1E+0 -+1:+1:+0E+0 --1:+0:-1E+0 -+0:-1:+1E+0 --1:-1:+0E+0 --1:+1:-2E+0 -+1:-1:+2E+0 -+9:+1:+8E+0 -+99:+1:+98E+0 -+999:+1:+998E+0 -+9999:+1:+9998E+0 -+99999:+1:+99998E+0 -+999999:+1:+999998E+0 -+9999999:+1:+9999998E+0 -+99999999:+1:+99999998E+0 -+999999999:+1:+999999998E+0 -+9999999999:+1:+9999999998E+0 -+99999999999:+1:+99999999998E+0 -+10:-1:+11E+0 -+100:-1:+101E+0 -+1000:-1:+1001E+0 -+10000:-1:+10001E+0 -+100000:-1:+100001E+0 -+1000000:-1:+1000001E+0 -+10000000:-1:+10000001E+0 -+100000000:-1:+100000001E+0 -+1000000000:-1:+1000000001E+0 -+10000000000:-1:+10000000001E+0 -+123456789:+987654321:-864197532E+0 --123456789:+987654321:-111111111E+1 --123456789:-987654321:+864197532E+0 -+123456789:-987654321:+111111111E+1 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+0:+1:+0E+0 -+1:+0:+0E+0 -+0:-1:+0E+0 --1:+0:+0E+0 -+123456789123456789:+0:+0E+0 -+0:+123456789123456789:+0E+0 --1:-1:+1E+0 --1:+1:-1E+0 -+1:-1:-1E+0 -+1:+1:+1E+0 -+2:+3:+6E+0 --2:+3:-6E+0 -+2:-3:-6E+0 --2:-3:+6E+0 -+111:+111:+12321E+0 -+10101:+10101:+102030201E+0 -+1001001:+1001001:+1002003002001E+0 -+100010001:+100010001:+10002000300020001E+0 -+10000100001:+10000100001:+100002000030000200001E+0 -+11111111111:+9:+99999999999E+0 -+22222222222:+9:+199999999998E+0 -+33333333333:+9:+299999999997E+0 -+44444444444:+9:+399999999996E+0 -+55555555555:+9:+499999999995E+0 -+66666666666:+9:+599999999994E+0 -+77777777777:+9:+699999999993E+0 -+88888888888:+9:+799999999992E+0 -+99999999999:+9:+899999999991E+0 -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0E+0 -+1:+0:NaN -+0:-1:+0E+0 --1:+0:NaN -+1:+1:+1E+0 --1:-1:+1E+0 -+1:-1:-1E+0 --1:+1:-1E+0 -+1:+2:+5E-1 -+2:+1:+2E+0 -+10:+5:+2E+0 -+100:+4:+25E+0 -+1000:+8:+125E+0 -+10000:+16:+625E+0 -+10000:-16:-625E+0 -+999999999999:+9:+111111111111E+0 -+999999999999:+99:+10101010101E+0 -+999999999999:+999:+1001001001E+0 -+999999999999:+9999:+100010001E+0 -+999999999999999:+99999:+10000100001E+0 -+1000000000:+9:+1111111111111111111111111111111111111111E-31 -+2000000000:+9:+2222222222222222222222222222222222222222E-31 -+3000000000:+9:+3333333333333333333333333333333333333333E-31 -+4000000000:+9:+4444444444444444444444444444444444444444E-31 -+5000000000:+9:+5555555555555555555555555555555555555556E-31 -+6000000000:+9:+6666666666666666666666666666666666666667E-31 -+7000000000:+9:+7777777777777777777777777777777777777778E-31 -+8000000000:+9:+8888888888888888888888888888888888888889E-31 -+9000000000:+9:+1E+9 -+35500000:+113:+3141592920353982300884955752212389380531E-34 -+71000000:+226:+3141592920353982300884955752212389380531E-34 -+106500000:+339:+3141592920353982300884955752212389380531E-34 -+1000000000:+3:+3333333333333333333333333333333333333333E-31 -$bigfloat::div_scale = 20 -+1000000000:+9:+11111111111111111111E-11 -+2000000000:+9:+22222222222222222222E-11 -+3000000000:+9:+33333333333333333333E-11 -+4000000000:+9:+44444444444444444444E-11 -+5000000000:+9:+55555555555555555556E-11 -+6000000000:+9:+66666666666666666667E-11 -+7000000000:+9:+77777777777777777778E-11 -+8000000000:+9:+88888888888888888889E-11 -+9000000000:+9:+1E+9 -+35500000:+113:+314159292035398230088E-15 -+71000000:+226:+314159292035398230088E-15 -+106500000:+339:+31415929203539823009E-14 -+1000000000:+3:+33333333333333333333E-11 -$bigfloat::div_scale = 40 -&fsqrt -+0:+0E+0 --1:NaN --2:NaN --16:NaN --123.456:NaN -+1:+1E+0 -+1.44:+12E-1 -+2:+141421356237309504880168872420969807857E-38 -+4:+2E+0 -+16:+4E+0 -+100:+1E+1 -+123.456:+1111107555549866648462149404118219234119E-38 -+15241.383936:+123456E-3 diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t deleted file mode 100755 index aa45651..0000000 --- a/contrib/perl5/t/lib/bigfltpm.t +++ /dev/null @@ -1,478 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::BigFloat; - -$test = 0; -$| = 1; -print "1..370\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;"; - } elsif ($f eq "fmod") { - $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"; - } - } - else { - - $ans1_str = defined $ans1? "$ans1" : ""; - if ($ans1_str eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -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 -abc:NaN -+0:0. -+1:-1. --1:1. -+123456789:-123456789. --123456789:123456789. -+123.456789:-123.456789 --123456.789:123456.789 -&fabs -abc:NaN -+0:0. -+1:1. --1:1. -+123456789:123456789. --123456789:123456789. -+123.456789:123.456789 --123456.789:123456.789 -&fround -$Math::BigFloat::rnd_mode = 'trunc' -+10123456789:5:10123000000 --10123456789:5:-10123000000 -+10123456789:9:10123456700 --10123456789:9:-10123456700 -+101234500:6:101234000 --101234500:6:-101234000 -$Math::BigFloat::rnd_mode = 'zero' -+20123456789:5:20123000000 --20123456789:5:-20123000000 -+20123456789:9:20123456800 --20123456789:9:-20123456800 -+201234500:6:201234000 --201234500:6:-201234000 -$Math::BigFloat::rnd_mode = '+inf' -+30123456789:5:30123000000 --30123456789:5:-30123000000 -+30123456789:9:30123456800 --30123456789:9:-30123456800 -+301234500:6:301235000 --301234500:6:-301234000 -$Math::BigFloat::rnd_mode = '-inf' -+40123456789:5:40123000000 --40123456789:5:-40123000000 -+40123456789:9:40123456800 --40123456789:9:-40123456800 -+401234500:6:401234000 --401234500:6:-401235000 -$Math::BigFloat::rnd_mode = 'odd' -+50123456789:5:50123000000 --50123456789:5:-50123000000 -+50123456789:9:50123456800 --50123456789:9:-50123456800 -+501234500:6:501235000 --501234500:6:-501235000 -$Math::BigFloat::rnd_mode = 'even' -+60123456789:5:60123000000 --60123456789:5:-60123000000 -+60123456789:9:60123456800 --60123456789:9:-60123456800 -+601234500:6:601234000 --601234500:6:-601234000 -&ffround -$Math::BigFloat::rnd_mode = 'trunc' -+1.23:-1:1.2 --1.23:-1:-1.2 -+1.27:-1:1.2 --1.27:-1:-1.2 -+1.25:-1:1.2 --1.25:-1:-1.2 -+1.35:-1:1.3 --1.35:-1:-1.3 --0.006:-1:0 --0.006:-2:0 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'zero' -+2.23:-1:/2.2(?:0{5}\d+)? --2.23:-1:/-2.2(?:0{5}\d+)? -+2.27:-1:/2.(?:3|29{5}\d+) --2.27:-1:/-2.(?:3|29{5}\d+) -+2.25:-1:/2.2(?:0{5}\d+)? --2.25:-1:/-2.2(?:0{5}\d+)? -+2.35:-1:/2.(?:3|29{5}\d+) --2.35:-1:/-2.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = '+inf' -+3.23:-1:/3.2(?:0{5}\d+)? --3.23:-1:/-3.2(?:0{5}\d+)? -+3.27:-1:/3.(?:3|29{5}\d+) --3.27:-1:/-3.(?:3|29{5}\d+) -+3.25:-1:/3.(?:3|29{5}\d+) --3.25:-1:/-3.2(?:0{5}\d+)? -+3.35:-1:/3.(?:4|39{5}\d+) --3.35:-1:/-3.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = '-inf' -+4.23:-1:/4.2(?:0{5}\d+)? --4.23:-1:/-4.2(?:0{5}\d+)? -+4.27:-1:/4.(?:3|29{5}\d+) --4.27:-1:/-4.(?:3|29{5}\d+) -+4.25:-1:/4.2(?:0{5}\d+)? --4.25:-1:/-4.(?:3|29{5}\d+) -+4.35:-1:/4.(?:3|29{5}\d+) --4.35:-1:/-4.(?:4|39{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'odd' -+5.23:-1:/5.2(?:0{5}\d+)? --5.23:-1:/-5.2(?:0{5}\d+)? -+5.27:-1:/5.(?:3|29{5}\d+) --5.27:-1:/-5.(?:3|29{5}\d+) -+5.25:-1:/5.(?:3|29{5}\d+) --5.25:-1:/-5.(?:3|29{5}\d+) -+5.35:-1:/5.(?:3|29{5}\d+) --5.35:-1:/-5.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'even' -+6.23:-1:/6.2(?:0{5}\d+)? --6.23:-1:/-6.2(?:0{5}\d+)? -+6.27:-1:/6.(?:3|29{5}\d+) --6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) --6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) -+6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) --6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 --1.1:0:-1 -+0:-1.1:1 -+1.1:+0:1 -+0:+1.1:-1 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+1:+0:1. -+0:+1:1. -+1:+1:2. --1:+0:-1. -+0:-1:-1. --1:-1:-2. --1:+1:0. -+1:-1:0. -+9:+1:10. -+99:+1:100. -+999:+1:1000. -+9999:+1:10000. -+99999:+1:100000. -+999999:+1:1000000. -+9999999:+1:10000000. -+99999999:+1:100000000. -+999999999:+1:1000000000. -+9999999999:+1:10000000000. -+99999999999:+1:100000000000. -+10:-1:9. -+100:-1:99. -+1000:-1:999. -+10000:-1:9999. -+100000:-1:99999. -+1000000:-1:999999. -+10000000:-1:9999999. -+100000000:-1:99999999. -+1000000000:-1:999999999. -+10000000000:-1:9999999999. -+123456789:+987654321:1111111110. --123456789:+987654321:864197532. --123456789:-987654321:-1111111110. -+123456789:-987654321:-864197532. -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+1:+0:1. -+0:+1:-1. -+1:+1:0. --1:+0:-1. -+0:-1:1. --1:-1:0. --1:+1:-2. -+1:-1:2. -+9:+1:8. -+99:+1:98. -+999:+1:998. -+9999:+1:9998. -+99999:+1:99998. -+999999:+1:999998. -+9999999:+1:9999998. -+99999999:+1:99999998. -+999999999:+1:999999998. -+9999999999:+1:9999999998. -+99999999999:+1:99999999998. -+10:-1:11. -+100:-1:101. -+1000:-1:1001. -+10000:-1:10001. -+100000:-1:100001. -+1000000:-1:1000001. -+10000000:-1:10000001. -+100000000:-1:100000001. -+1000000000:-1:1000000001. -+10000000000:-1:10000000001. -+123456789:+987654321:-864197532. --123456789:+987654321:-1111111110. --123456789:-987654321:864197532. -+123456789:-987654321:1111111110. -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+0:+1:0. -+1:+0:0. -+0:-1:0. --1:+0:0. -+123456789123456789:+0:0. -+0:+123456789123456789:0. --1:-1:1. --1:+1:-1. -+1:-1:-1. -+1:+1:1. -+2:+3:6. --2:+3:-6. -+2:-3:-6. --2:-3:6. -+111:+111:12321. -+10101:+10101:102030201. -+1001001:+1001001:1002003002001. -+100010001:+100010001:10002000300020001. -+10000100001:+10000100001:100002000030000200001. -+11111111111:+9:99999999999. -+22222222222:+9:199999999998. -+33333333333:+9:299999999997. -+44444444444:+9:399999999996. -+55555555555:+9:499999999995. -+66666666666:+9:599999999994. -+77777777777:+9:699999999993. -+88888888888:+9:799999999992. -+99999999999:+9:899999999991. -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:0. -+1:+0:NaN -+0:-1:0. --1:+0:NaN -+1:+1:1. --1:-1:1. -+1:-1:-1. --1:+1:-1. -+1:+2:.5 -+2:+1:2. -+10:+5:2. -+100:+4:25. -+1000:+8:125. -+10000:+16:625. -+10000:-16:-625. -+999999999999:+9:111111111111. -+999999999999:+99:10101010101. -+999999999999:+999:1001001001. -+999999999999:+9999:100010001. -+999999999999999:+99999:10000100001. -+1000000000:+9:111111111.1111111111111111111111111111111 -+2000000000:+9:222222222.2222222222222222222222222222222 -+3000000000:+9:333333333.3333333333333333333333333333333 -+4000000000:+9:444444444.4444444444444444444444444444444 -+5000000000:+9:555555555.5555555555555555555555555555556 -+6000000000:+9:666666666.6666666666666666666666666666667 -+7000000000:+9:777777777.7777777777777777777777777777778 -+8000000000:+9:888888888.8888888888888888888888888888889 -+9000000000:+9:1000000000. -+35500000:+113:314159.2920353982300884955752212389380531 -+71000000:+226:314159.2920353982300884955752212389380531 -+106500000:+339:314159.2920353982300884955752212389380531 -+1000000000:+3:333333333.3333333333333333333333333333333 -$Math::BigFloat::div_scale = 20 -+1000000000:+9:111111111.11111111111 -+2000000000:+9:222222222.22222222222 -+3000000000:+9:333333333.33333333333 -+4000000000:+9:444444444.44444444444 -+5000000000:+9:555555555.55555555556 -+6000000000:+9:666666666.66666666667 -+7000000000:+9:777777777.77777777778 -+8000000000:+9:888888888.88888888889 -+9000000000:+9:1000000000. -+35500000:+113:314159.292035398230088 -+71000000:+226:314159.292035398230088 -+106500000:+339:314159.29203539823009 -+1000000000:+3:333333333.33333333333 -$Math::BigFloat::div_scale = 40 -&fsqrt -+0:0 --1:/^(?i:0|\?|NaNQ?)$ --2:/^(?i:0|\?|NaNQ?)$ --16:/^(?i:0|\?|NaNQ?)$ --123.456:/^(?i:0|\?|NaNQ?)$ -+1:1. -+1.44:1.2 -+2:1.41421356237309504880168872420969807857 -+4:2. -+16:4. -+100:10. -+123.456:11.11107555549866648462149404118219234119 -+15241.383936:123.456 -&fmod -+0:0:NaN -+0:1:0. -+3:1:0. -+5:2:1. -+9:4:1. -+9:5:4. -+9000:56:40. -+56:9000:56. diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t deleted file mode 100755 index 034c5c6..0000000 --- a/contrib/perl5/t/lib/bigint.t +++ /dev/null @@ -1,282 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigint.pl"; - -$test = 0; -$| = 1; -print "1..246\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } 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__ -&bnorm -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 -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -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 -&badd -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 -&bsub -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 -&bmul -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 -&bdiv -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:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -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:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t deleted file mode 100755 index e76f246..0000000 --- a/contrib/perl5/t/lib/bigintpm.t +++ /dev/null @@ -1,377 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::BigInt; - -$test = 0; -$| = 1; -print "1..278\n"; -while (<DATA>) { - chop; - if (s/^&//) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "\$x = new Math::BigInt \"$args[0]\";"; - if ($f eq "bnorm"){ - $try .= "\$x+0;"; - } elsif ($f eq "bneg") { - $try .= "-\$x;"; - } elsif ($f eq "babs") { - $try .= "abs \$x;"; - } else { - $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq "bcmp"){ - $try .= "\$x <=> \$y;"; - }elsif ($f eq "badd"){ - $try .= "\$x + \$y;"; - }elsif ($f eq "bsub"){ - $try .= "\$x - \$y;"; - }elsif ($f eq "bmul"){ - $try .= "\$x * \$y;"; - }elsif ($f eq "bdiv"){ - $try .= "\$x / \$y;"; - }elsif ($f eq "bmod"){ - $try .= "\$x % \$y;"; - }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"; - $ans1 = eval $try; - if ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - 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 - 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 -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -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 -+100:+5:1 -&badd -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 -&bsub -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 -&bmul -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 -&bdiv -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:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -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:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 -&blsft -abc:abc:NaN -+2:+2:+8 -+1:+32:+4294967296 -+1:+48:+281474976710656 -+8:-2:NaN -&brsft -abc:abc:NaN -+8:+2:+2 -+4294967296:+32:+1 -+281474976710656:+48:+1 -+2:-2:NaN -&band -abc:abc:NaN -+8:+2:+0 -+281474976710656:+0:+0 -+281474976710656:+1:+0 -+281474976710656:+281474976710656:+281474976710656 -&bior -abc:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+281474976710656 -&bxor -abc:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+0 -&bnot -abc:NaN -+0:-1 -+8:-9 -+281474976710656:-281474976710657 diff --git a/contrib/perl5/t/lib/cgi-esc.t b/contrib/perl5/t/lib/cgi-esc.t deleted file mode 100755 index f0471cf..0000000 --- a/contrib/perl5/t/lib/cgi-esc.t +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to escape() and unescape() punctuation characters -# except for qw(- . _). -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..59\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI::Util qw(escape unescape); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# ASCII order, ASCII codepoints, ASCII repertoire - -my %punct = ( - ' ' => '20', '!' => '21', '"' => '22', '#' => '23', - '$' => '24', '%' => '25', '&' => '26', '\'' => '27', - '(' => '28', ')' => '29', '*' => '2A', '+' => '2B', - ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E' - ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D', - '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C', - ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F', - '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E', - ); - -# The sort order may not be ASCII on EBCDIC machines: - -my $i = 1; - -foreach(sort(keys(%punct))) { - $i++; - my $escape = "AbC\%$punct{$_}dEF"; - my $cgi_escape = escape("AbC$_" . "dEF"); - test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape"); - $i++; - my $unescape = "AbC$_" . "dEF"; - my $cgi_unescape = unescape("AbC\%$punct{$_}dEF"); - test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape"); -} - diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t deleted file mode 100755 index 2922903..0000000 --- a/contrib/perl5/t/lib/cgi-form.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..17\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$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'; - -test(2,start_form(-action=>'foobar',-method=>'get') eq - qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), - "start_form()"); - -test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), - "textfield({-name,-value,-override})"); -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), - "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), - "checkbox()"); -test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<input type="checkbox" name="weather" value="dull" checked />forecast), - "checkbox()"); - -test(13,radio_group(-name=>'game') eq - qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); -test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); - -test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), - 'checkbox_group()'); - -test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq - qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), - 'checkbox_group()'); -test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<select name="game"> -<option value="checkers">checkers</option> -<option value="chess">chess</option> -<option selected value="cribbage">cribbage</option> -</select> -END - diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t deleted file mode 100755 index 3b9722e..0000000 --- a/contrib/perl5/t/lib/cgi-function.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..27\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI (':standard','keywords'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; - -# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS -# is that a CR character gets inserted automatically in the web server -# case but not internal to perl's double quoted strings "\n". This -# test would need to be modified to use the "\015\012" on VMS if it -# were actually run through a web server. -# Thanks to Peter Prymmer for this - -if ($^O eq 'VMS') { $CRLF = "\n"; } - -# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII -# translation hence CRLF is used as \r\n within CGI.pm on such machines. - -if (ord("\t") != 9) { $CRLF = "\r\n"; } - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$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'; - -test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(4,param() == 2,"CGI::param()"); -test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); -test(6,param('game') eq 'chess',"CGI::param()"); -test(7,param('weather') eq 'dull',"CGI::param()"); -test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); -test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(12,http('love') eq 'true',"CGI::http()"); -test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -Delete('foo'); -test(20,!param('foo'),'CGI::delete()'); - -CGI::_reset_globals(); -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); -test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); - -CGI::_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); -} else { - print "ok 23 # Skip\n"; - print "ok 24 # Skip\n"; -} -test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); -my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); -test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); -test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t deleted file mode 100755 index 93e5dac..0000000 --- a/contrib/perl5/t/lib/cgi-html.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..24\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1 />',"single tag"); -test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); -test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', - "distributive tag with attribute"); -{ - local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); -} -test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); -test(13,start_html() ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE html - PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> -</head><body> -END - ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); -my $h = header(-Cookie=>$cookie); -test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, - "header(-cookie)"); -test(18,start_h3 eq '<h3>'); -test(19,end_h3 eq '</h3>'); -test(20,start_table({-border=>undef}) eq '<table border>'); -test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); -charset('utf-8'); -if (ord("\t") == 9) { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> right</h1>'); -} -else { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> right</h1>'); -} -test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); -my $q = new CGI; -test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/contrib/perl5/t/lib/cgi-pretty.t b/contrib/perl5/t/lib/cgi-pretty.t deleted file mode 100755 index 14f6447..0000000 --- a/contrib/perl5/t/lib/cgi-pretty.t +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..5\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI::Pretty (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1>',"single tag"); -test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation"); -test(4,p('hi',pre('there'),'frog') eq -'<p> - hi <pre>there</pre> - frog -</p> -',"<pre> tags"); -test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq -'<p> - hi <a href="frog">there</a> - frog -</p> -',"as-is"); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t deleted file mode 100755 index fde3fd0..0000000 --- a/contrib/perl5/t/lib/cgi-request.t +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..33\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (); -use Config; -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# 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{SERVER_PROTOCOL} = 'HTTP/1.0'; -$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()"); -test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(5,$q->param() == 2,"CGI::param()"); -test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); -test(7,$q->param('game') eq 'chess',"CGI::param()"); -test(8,$q->param('weather') eq 'dull',"CGI::param()"); -test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); -test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(13,$q->http('love') eq 'true',"CGI::http()"); -test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -$q->delete('foo'); -test(21,!$q->param('foo'),'CGI::delete()'); - -$q->_reset_globals; -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(22,$q=new CGI,"CGI::new() redux"); -test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords'); -test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux"); -test(26,$q->param('foo') eq 'bar','CGI::param() redux'); -test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); -test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); - -# test tied interface -my $p = $q->Vars; -test(29,$p->{bar} eq 'froz',"tied interface fetch"); -$p->{bar} = join("\0",qw(foo bar baz)); -test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); - -# test posting -$q->_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(31,$q=new CGI,"CGI::new() from POST"); - test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); -} else { - print "ok 31 # Skip\n"; - print "ok 32 # Skip\n"; - print "ok 33 # Skip\n"; -} diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t deleted file mode 100755 index 2731136..0000000 --- a/contrib/perl5/t/lib/charnames.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -$| = 1; -print "1..15\n"; - -use charnames ':full'; - -print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; -print "ok 1\n"; - -{ - use bytes; # UTEST can switch utf8 on - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames ":full"; -"Here: \N{CYRILLIC SMALL LETTER BE}!"; -1 -EOE - or $@ !~ /above 0xFF/; - print "ok 2\n"; - # print "# \$res=$res \$\@='$@'\n"; - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames 'cyrillic'; -"Here: \N{Be}!"; -1 -EOE - or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; - print "ok 3\n"; -} - -# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt -$encoded_be = "\320\261"; -$encoded_alpha = "\316\261"; -$encoded_bet = "\327\221"; -$encoded_deseng = "\360\220\221\215"; - -sub to_bytes { - pack"a*", shift; -} - -{ - use charnames ':full'; - - print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; - print "ok 4\n"; - - use charnames qw(cyrillic greek :short); - - print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") - eq "$encoded_be,$encoded_alpha,$encoded_bet"; - print "ok 5\n"; -} - -{ - use charnames ':full'; - print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}"; - print "ok 6\n"; - print "not " unless length("\x{263a}") == 1; - print "ok 7\n"; - print "not " unless length("\N{WHITE SMILING FACE}") == 1; - print "ok 8\n"; - print "not " unless sprintf("%vx", "\x{263a}") eq "263a"; - print "ok 9\n"; - print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"; - print "ok 10\n"; - print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 11\n"; - print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 12\n"; -} - -{ - use charnames qw(:full); - use utf8; - - my $x = "\x{221b}"; - my $named = "\N{CUBE ROOT}"; - - print "not " unless ord($x) == ord($named); - print "ok 13\n"; -} - -{ - use charnames qw(:full); - use utf8; - print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; - print "ok 14\n"; -} - -{ - use charnames ':full'; - -# XXX this test breaks in 5.6.x because the Unicode database is missing -# "DESERET SMALL LETTER ENG". Uncomment after updating to Unicode 3.1 -# print "not " -# unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; - print "ok 15\n"; - -} - diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t deleted file mode 100755 index b5426ca..0000000 --- a/contrib/perl5/t/lib/checktree.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::CheckTree; - -# We assume that we run from the perl "t" directory. - -validate q{ - lib -d || die - lib/checktree.t -f || die -}; - -print "ok 1\n"; diff --git a/contrib/perl5/t/lib/class-struct.t b/contrib/perl5/t/lib/class-struct.t deleted file mode 100755 index 26505ba..0000000 --- a/contrib/perl5/t/lib/class-struct.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..8\n"; - -package aClass; - -sub new { bless {}, shift } - -sub meth { 42 } - -package MyObj; - -use Class::Struct; -use Class::Struct 'struct'; # test out both forms - -use Class::Struct SomeClass => { SomeElem => '$' }; - -struct( s => '$', a => '@', h => '%', c => 'aClass' ); - -my $obj = MyObj->new; - -$obj->s('foo'); - -print "not " unless $obj->s() eq 'foo'; -print "ok 1\n"; - -my $arf = $obj->a; - -print "not " unless ref $arf eq 'ARRAY'; -print "ok 2\n"; - -$obj->a(2, 'secundus'); - -print "not " unless $obj->a(2) eq 'secundus'; -print "ok 3\n"; - -my $hrf = $obj->h; - -print "not " unless ref $hrf eq 'HASH'; -print "ok 4\n"; - -$obj->h('x', 10); - -print "not " unless $obj->h('x') == 10; -print "ok 5\n"; - -my $orf = $obj->c; - -print "not " unless ref $orf eq 'aClass'; -print "ok 6\n"; - -print "not " unless $obj->c->meth() == 42; -print "ok 7\n"; - -my $obk = SomeClass->new(); - -$obk->SomeElem(123); - -print "not " unless $obk->SomeElem() == 123; -print "ok 8\n"; - diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t deleted file mode 100755 index 334374d..0000000 --- a/contrib/perl5/t/lib/complex.t +++ /dev/null @@ -1,979 +0,0 @@ -#!./perl - -# $RCSfile: complex.t,v $ -# -# Regression tests for the Math::Complex pacakge -# -- Raphael Manfredi since Sep 1996 -# -- Jarkko Hietaniemi since Mar 1997 -# -- Daniel S. Lewart since Sep 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Complex; - -use vars qw($VERSION); - -$VERSION = 1.91; - -my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); - -$test = 0; -$| = 1; -my @script = ( - 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . - "\n\n" -); -my $eps = 1e-13; - -if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-10; # results in Cray UNICOS, and occasionally also -} # cos(), sin(), cosh(), sinh(). The division - # of doubles is the current suspect. - -while (<DATA>) { - s/^\s+//; - next if $_ eq '' || /^\#/; - chomp; - $test_set = 0; # Assume not a test over a set of values - if (/^&(.+)/) { - $op = $1; - next; - } - elsif (/^\{(.+)\}/) { - set($1, \@set, \@val); - next; - } - elsif (s/^\|//) { - $test_set = 1; # Requests we loop over the set... - } - my @args = split(/:/); - if ($test_set == 1) { - my $i; - for ($i = 0; $i < @set; $i++) { - # complex number - $target = $set[$i]; - # textual value as found in set definition - $zvalue = $val[$i]; - test($zvalue, $target, @args); - } - } else { - test($op, undef, @args); - } -} - -# - -sub test_mutators { - my $op; - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->Re(2); - $z->Im(3); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless Re($z) == 2 and Im($z) == 3; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->abs(3 * sqrt(2)); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and - (arg($z) - pi / 4 ) < $eps and - (Re($z) - 3 ) < $eps and - (Im($z) - 3 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->arg(-3 / 4 * pi); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and - (abs($z) - sqrt(2) ) < $eps and - (Re($z) + 1 ) < $eps and - (Im($z) + 1 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); -} - -test_mutators(); - -my $constants = ' -my $i = cplx(0, 1); -my $pi = cplx(pi, 0); -my $pii = cplx(0, pi); -my $pip2 = cplx(pi/2, 0); -my $zero = cplx(0, 0); -'; - -push(@script, $constants); - - -# test the divbyzeros - -sub test_dbz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op divbyzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Division by zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -# test the logofzeros - -sub test_loz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op logofzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Logarithm of zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_dbz( - 'i/0', - 'acot(0)', - 'acot(+$i)', -# 'acoth(-1)', # Log of zero. - 'acoth(0)', - 'acoth(+1)', - 'acsc(0)', - 'acsch(0)', - 'asec(0)', - 'asech(0)', - 'atan($i)', -# 'atanh(-1)', # Log of zero. - 'atanh(+1)', - 'cot(0)', - 'coth(0)', - 'csc(0)', - 'csch(0)', - ); - -test_loz( - 'log($zero)', - 'atan(-$i)', - 'acot(-$i)', - 'atanh(-1)', - 'acoth(-1)', - ); - -# test the bad roots - -sub test_broot { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval 'root(2, $op)'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root rank must be/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_broot(qw(-3 -2.1 0 0.99)); - -sub test_display_format { - $test++; - push @script, <<EOS; - print "# package display_format cartesian?\n"; - print "not " unless Math::Complex->display_format eq 'cartesian'; - print "ok $test\n"; -EOS - - push @script, <<EOS; - my \$j = (root(1,3))[1]; - - \$j->display_format('polar'); -EOS - - $test++; - push @script, <<EOS; - print "# j display_format polar?\n"; - print "not " unless \$j->display_format eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "[1,2pi/3]"; - print "ok $test\n"; - - my %display_format; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{style} polar?\n"; - print "not " unless \$display_format{style} eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 2?\n"; - print "not " unless keys %display_format == 2; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '%.5f'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "-0.50000+0.86603i"; - print "ok $test\n"; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{format} %.5f?\n"; - print "not " unless \$display_format{format} eq '%.5f'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 3?\n"; - print "not " unless keys %display_format == 3; - print "ok $test\n"; - - \$j->display_format('format' => undef); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j display_format cartesian?\n"; - print "not " unless \$j->display_format eq 'cartesian'; - print "ok $test\n"; -EOS -} - -test_display_format(); - -print "1..$test\n"; -eval join '', @script; -die $@ if $@; - -sub abop { - my ($op) = @_; - - push(@script, qq(print "# $op=\n";)); -} - -sub test { - my ($op, $z, @args) = @_; - my ($baop) = 0; - $test++; - my $i; - $baop = 1 if ($op =~ s/;=$//); - for ($i = 0; $i < @args; $i++) { - $val = value($args[$i]); - push @script, "\$z$i = $val;\n"; - } - if (defined $z) { - $args = "'$op'"; # Really the value - $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0"; - push @script, "\$res = $try; "; - push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n"; - } else { - my ($try, $args); - if (@args == 2) { - $try = "$op \$z0"; - $args = "'$args[0]'"; - } else { - $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1"; - $args = "'$args[0]', '$args[1]'"; - } - push @script, "\$res = $try; "; - push @script, "check($test, '$try', \$res, \$z$#args, $args);\n"; - if (@args > 2 and $baop) { # binary assignment ops - $test++; - # check the op= works - push @script, <<EOB; -{ - my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); - - my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0); - - my \$zb = cplx(\$z1r, \$z1i); - - \$za $op= \$zb; - my (\$zbr, \$zbi) = \@{\$zb->cartesian}; - - check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args); -EOB - $test++; - # check that the rhs has not changed - push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); - push @script, qq(print "ok $test\\n";\n); - push @script, "}\n"; - } - } -} - -sub set { - my ($set, $setref, $valref) = @_; - @{$setref} = (); - @{$valref} = (); - my @set = split(/;\s*/, $set); - my @res; - my $i; - for ($i = 0; $i < @set; $i++) { - push(@{$valref}, $set[$i]); - my $val = value($set[$i]); - push @script, "\$s$i = $val;\n"; - push @{$setref}, "\$s$i"; - } -} - -sub value { - local ($_) = @_; - if (/^\s*\((.*),(.*)\)/) { - return "cplx($1,$2)"; - } - elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) { - return "cplx($1,0)"; - } - elsif (/^\s*\[(.*),(.*)\]/) { - return "cplxe($1,$2)"; - } - elsif (/^\s*'(.*)'/) { - my $ex = $1; - $ex =~ s/\bz\b/$target/g; - $ex =~ s/\br\b/abs($target)/g; - $ex =~ s/\bt\b/arg($target)/g; - $ex =~ s/\ba\b/Re($target)/g; - $ex =~ s/\bb\b/Im($target)/g; - return $ex; - } - elsif (/^\s*"(.*)"/) { - return "\"$1\""; - } - return $_; -} - -sub check { - my ($test, $try, $got, $expected, @z) = @_; - - print "# @_\n"; - - if ("$got" eq "$expected" - || - ($expected =~ /^-?\d/ && $got == $expected) - || - (abs($got - $expected) < $eps) - ) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]"; - print "# '$try' expected: '$expected' got: '$got' for $args\n"; - } -} - -sub addsq { - my ($z1, $z2) = @_; - return ($z1 + i*$z2) * ($z1 - i*$z2); -} - -sub subsq { - my ($z1, $z2) = @_; - return ($z1 + $z2) * ($z1 - $z2); -} - -__END__ -&+;= -(3,4):(3,4):(6,8) -(-3,4):(3,-4):(0,0) -(3,4):-3:(0,4) -1:(4,2):(5,2) -[2,0]:[2,pi]:(0,0) - -&++ -(2,1):(3,1) - -&-;= -(2,3):(-2,-3) -[2,pi/2]:[2,-(pi)/2] -2:[2,0]:(0,0) -[3,0]:2:(1,0) -3:(4,5):(-1,-5) -(4,5):3:(1,5) -(2,1):(3,5):(-1,-4) - -&-- -(1,2):(0,2) -[2,pi]:[3,pi] - -&*;= -(0,1):(0,1):(-1,0) -(4,5):(1,0):(4,5) -[2,2*pi/3]:(1,0):[2,2*pi/3] -2:(0,1):(0,2) -(0,1):3:(0,3) -(0,1):(4,1):(-1,4) -(2,1):(4,-1):(9,2) - -&/;= -(3,4):(3,4):(1,0) -(4,-5):1:(4,-5) -1:(0,1):(0,-1) -(0,6):(0,2):(3,0) -(9,2):(4,-1):(2,1) -[4,pi]:[2,pi/2]:[2,pi/2] -[2,pi/2]:[4,pi]:[0.5,-(pi)/2] - -&**;= -(2,0):(3,0):(8,0) -(3,0):(2,0):(9,0) -(2,3):(4,0):(-119,-120) -(0,0):(1,0):(0,0) -(0,0):(2,3):(0,0) -(1,0):(0,0):(1,0) -(1,0):(1,0):(1,0) -(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 -(-3,4):-3 -[1,pi/2]:0 - -&Im -(3,4):4 -(3,-4):-4 -[1,pi/2]:1 - -&abs -(3,4):5 -(-3,4):5 - -&arg -[2,0]:0 -[-2,0]:pi - -&~ -(4,5):(4,-5) -(-3,4):(-3,-4) -[2,pi/2]:[2,-(pi)/2] - -&< -(3,4):(1,2):0 -(3,4):(3,2):0 -(3,4):(3,8):1 -(4,4):(5,129):1 - -&== -(3,4):(4,5):0 -(3,4):(3,5):0 -(3,4):(2,4):0 -(3,4):(3,4):1 - -&sqrt --9:(0,3) -(-100,0):(0,10) -(16,-30):(5,-3) - -&stringify_cartesian -(-100,0):"-100" -(0,1):"i" -(4,-3):"4-3i" -(4,0):"4" -(-4,0):"-4" -(-2,4):"-2+4i" -(-2,-1):"-2-i" - -&stringify_polar -[-1, 0]:"[1,pi]" -[1, pi/3]:"[1,pi/3]" -[6, -2*pi/3]:"[6,-2pi/3]" -[0.5, -9*pi/11]:"[0.5,-9pi/11]" - -{ (4,3); [3,2]; (-3,4); (0,2); [2,1] } - -|'z + ~z':'2*Re(z)' -|'z - ~z':'2*i*Im(z)' -|'z * ~z':'abs(z) * abs(z)' - -{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } - -|'(root(z, 4))[1] ** 4':'z' -|'(root(z, 5))[3] ** 5':'z' -|'(root(z, 8))[7] ** 8':'z' -|'abs(z)':'r' -|'acot(z)':'acotan(z)' -|'acsc(z)':'acosec(z)' -|'acsc(z)':'asin(1 / z)' -|'asec(z)':'acos(1 / z)' -|'cbrt(z)':'cbrt(r) * exp(i * t/3)' -|'cos(acos(z))':'z' -|'addsq(cos(z), sin(z))':1 -|'cos(z)':'cosh(i*z)' -|'subsq(cosh(z), sinh(z))':1 -|'cot(acot(z))':'z' -|'cot(z)':'1 / tan(z)' -|'cot(z)':'cotan(z)' -|'csc(acsc(z))':'z' -|'csc(z)':'1 / sin(z)' -|'csc(z)':'cosec(z)' -|'exp(log(z))':'z' -|'exp(z)':'exp(a) * exp(i * b)' -|'ln(z)':'log(z)' -|'log(exp(z))':'z' -|'log(z)':'log(r) + i*t' -|'log10(z)':'log(z) / log(10)' -|'logn(z, 2)':'log(z) / log(2)' -|'logn(z, 3)':'log(z) / log(3)' -|'sec(asec(z))':'z' -|'sec(z)':'1 / cos(z)' -|'sin(asin(z))':'z' -|'sin(i * z)':'i * sinh(z)' -|'sqrt(z) * sqrt(z)':'z' -|'sqrt(z)':'sqrt(r) * exp(i * t/2)' -|'tan(atan(z))':'z' -|'z**z':'exp(z * log(z))' - -{ (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) } - -|'cosh(acosh(z))':'z' -|'coth(acoth(z))':'z' -|'coth(z)':'1 / tanh(z)' -|'coth(z)':'cotanh(z)' -|'csch(acsch(z))':'z' -|'csch(z)':'1 / sinh(z)' -|'csch(z)':'cosech(z)' -|'sech(asech(z))':'z' -|'sech(z)':'1 / cosh(z)' -|'sinh(asinh(z))':'z' -|'tanh(atanh(z))':'z' - -{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) } - -|'acos(cos(z)) ** 2':'z * z' -|'acosh(cosh(z)) ** 2':'z * z' -|'acoth(z)':'acotanh(z)' -|'acoth(z)':'atanh(1 / z)' -|'acsch(z)':'acosech(z)' -|'acsch(z)':'asinh(1 / z)' -|'asech(z)':'acosh(1 / z)' -|'asin(sin(z))':'z' -|'asinh(sinh(z))':'z' -|'atan(tan(z))':'z' -|'atanh(tanh(z))':'z' - -&log -(-2.0,0):( 0.69314718055995, 3.14159265358979) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -0.69314718055995, 3.14159265358979) -( 0.5,0):( -0.69314718055995, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0.69314718055995, 0 ) - -&log -( 2, 3):( 1.28247467873077, 0.98279372324733) -(-2, 3):( 1.28247467873077, 2.15879893034246) -(-2,-3):( 1.28247467873077, -2.15879893034246) -( 2,-3):( 1.28247467873077, -0.98279372324733) - -&sin -(-2.0,0):( -0.90929742682568, 0 ) -(-1.0,0):( -0.84147098480790, 0 ) -(-0.5,0):( -0.47942553860420, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.47942553860420, 0 ) -( 1.0,0):( 0.84147098480790, 0 ) -( 2.0,0):( 0.90929742682568, 0 ) - -&sin -( 2, 3):( 9.15449914691143, -4.16890695996656) -(-2, 3):( -9.15449914691143, -4.16890695996656) -(-2,-3):( -9.15449914691143, 4.16890695996656) -( 2,-3):( 9.15449914691143, 4.16890695996656) - -&cos -(-2.0,0):( -0.41614683654714, 0 ) -(-1.0,0):( 0.54030230586814, 0 ) -(-0.5,0):( 0.87758256189037, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.87758256189037, 0 ) -( 1.0,0):( 0.54030230586814, 0 ) -( 2.0,0):( -0.41614683654714, 0 ) - -&cos -( 2, 3):( -4.18962569096881, -9.10922789375534) -(-2, 3):( -4.18962569096881, 9.10922789375534) -(-2,-3):( -4.18962569096881, -9.10922789375534) -( 2,-3):( -4.18962569096881, 9.10922789375534) - -&tan -(-2.0,0):( 2.18503986326152, 0 ) -(-1.0,0):( -1.55740772465490, 0 ) -(-0.5,0):( -0.54630248984379, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54630248984379, 0 ) -( 1.0,0):( 1.55740772465490, 0 ) -( 2.0,0):( -2.18503986326152, 0 ) - -&tan -( 2, 3):( -0.00376402564150, 1.00323862735361) -(-2, 3):( 0.00376402564150, 1.00323862735361) -(-2,-3):( 0.00376402564150, -1.00323862735361) -( 2,-3):( -0.00376402564150, -1.00323862735361) - -&sec -(-2.0,0):( -2.40299796172238, 0 ) -(-1.0,0):( 1.85081571768093, 0 ) -(-0.5,0):( 1.13949392732455, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.13949392732455, 0 ) -( 1.0,0):( 1.85081571768093, 0 ) -( 2.0,0):( -2.40299796172238, 0 ) - -&sec -( 2, 3):( -0.04167496441114, 0.09061113719624) -(-2, 3):( -0.04167496441114, -0.09061113719624) -(-2,-3):( -0.04167496441114, 0.09061113719624) -( 2,-3):( -0.04167496441114, -0.09061113719624) - -&csc -(-2.0,0):( -1.09975017029462, 0 ) -(-1.0,0):( -1.18839510577812, 0 ) -(-0.5,0):( -2.08582964293349, 0 ) -( 0.5,0):( 2.08582964293349, 0 ) -( 1.0,0):( 1.18839510577812, 0 ) -( 2.0,0):( 1.09975017029462, 0 ) - -&csc -( 2, 3):( 0.09047320975321, 0.04120098628857) -(-2, 3):( -0.09047320975321, 0.04120098628857) -(-2,-3):( -0.09047320975321, -0.04120098628857) -( 2,-3):( 0.09047320975321, -0.04120098628857) - -&cot -(-2.0,0):( 0.45765755436029, 0 ) -(-1.0,0):( -0.64209261593433, 0 ) -(-0.5,0):( -1.83048772171245, 0 ) -( 0.5,0):( 1.83048772171245, 0 ) -( 1.0,0):( 0.64209261593433, 0 ) -( 2.0,0):( -0.45765755436029, 0 ) - -&cot -( 2, 3):( -0.00373971037634, -0.99675779656936) -(-2, 3):( 0.00373971037634, -0.99675779656936) -(-2,-3):( 0.00373971037634, 0.99675779656936) -( 2,-3):( -0.00373971037634, 0.99675779656936) - -&asin -(-2.0,0):( -1.57079632679490, 1.31695789692482) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -0.52359877559830, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52359877559830, 0 ) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 1.57079632679490, -1.31695789692482) - -&asin -( 2, 3):( 0.57065278432110, 1.98338702991654) -(-2, 3):( -0.57065278432110, 1.98338702991654) -(-2,-3):( -0.57065278432110, -1.98338702991654) -( 2,-3):( 0.57065278432110, -1.98338702991654) - -&acos -(-2.0,0):( 3.14159265358979, -1.31695789692482) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 2.09439510239320, 0 ) -( 0.0,0):( 1.57079632679490, 0 ) -( 0.5,0):( 1.04719755119660, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.31695789692482) - -&acos -( 2, 3):( 1.00014354247380, -1.98338702991654) -(-2, 3):( 2.14144911111600, -1.98338702991654) -(-2,-3):( 2.14144911111600, 1.98338702991654) -( 2,-3):( 1.00014354247380, 1.98338702991654) - -&atan -(-2.0,0):( -1.10714871779409, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -0.46364760900081, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46364760900081, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 1.10714871779409, 0 ) - -&atan -( 2, 3):( 1.40992104959658, 0.22907268296854) -(-2, 3):( -1.40992104959658, 0.22907268296854) -(-2,-3):( -1.40992104959658, -0.22907268296854) -( 2,-3):( 1.40992104959658, -0.22907268296854) - -&asec -(-2.0,0):( 2.09439510239320, 0 ) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 3.14159265358979, -1.31695789692482) -( 0.5,0):( 0 , 1.31695789692482) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.04719755119660, 0 ) - -&asec -( 2, 3):( 1.42041072246703, 0.23133469857397) -(-2, 3):( 1.72118193112276, 0.23133469857397) -(-2,-3):( 1.72118193112276, -0.23133469857397) -( 2,-3):( 1.42041072246703, -0.23133469857397) - -&acsc -(-2.0,0):( -0.52359877559830, 0 ) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -1.57079632679490, 1.31695789692482) -( 0.5,0):( 1.57079632679490, -1.31695789692482) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 0.52359877559830, 0 ) - -&acsc -( 2, 3):( 0.15038560432786, -0.23133469857397) -(-2, 3):( -0.15038560432786, -0.23133469857397) -(-2,-3):( -0.15038560432786, 0.23133469857397) -( 2,-3):( 0.15038560432786, 0.23133469857397) - -&acot -(-2.0,0):( -0.46364760900081, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -1.10714871779409, 0 ) -( 0.5,0):( 1.10714871779409, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 0.46364760900081, 0 ) - -&acot -( 2, 3):( 0.16087527719832, -0.22907268296854) -(-2, 3):( -0.16087527719832, -0.22907268296854) -(-2,-3):( -0.16087527719832, 0.22907268296854) -( 2,-3):( 0.16087527719832, 0.22907268296854) - -&sinh -(-2.0,0):( -3.62686040784702, 0 ) -(-1.0,0):( -1.17520119364380, 0 ) -(-0.5,0):( -0.52109530549375, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52109530549375, 0 ) -( 1.0,0):( 1.17520119364380, 0 ) -( 2.0,0):( 3.62686040784702, 0 ) - -&sinh -( 2, 3):( -3.59056458998578, 0.53092108624852) -(-2, 3):( 3.59056458998578, 0.53092108624852) -(-2,-3):( 3.59056458998578, -0.53092108624852) -( 2,-3):( -3.59056458998578, -0.53092108624852) - -&cosh -(-2.0,0):( 3.76219569108363, 0 ) -(-1.0,0):( 1.54308063481524, 0 ) -(-0.5,0):( 1.12762596520638, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.12762596520638, 0 ) -( 1.0,0):( 1.54308063481524, 0 ) -( 2.0,0):( 3.76219569108363, 0 ) - -&cosh -( 2, 3):( -3.72454550491532, 0.51182256998738) -(-2, 3):( -3.72454550491532, -0.51182256998738) -(-2,-3):( -3.72454550491532, 0.51182256998738) -( 2,-3):( -3.72454550491532, -0.51182256998738) - -&tanh -(-2.0,0):( -0.96402758007582, 0 ) -(-1.0,0):( -0.76159415595576, 0 ) -(-0.5,0):( -0.46211715726001, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46211715726001, 0 ) -( 1.0,0):( 0.76159415595576, 0 ) -( 2.0,0):( 0.96402758007582, 0 ) - -&tanh -( 2, 3):( 0.96538587902213, -0.00988437503832) -(-2, 3):( -0.96538587902213, -0.00988437503832) -(-2,-3):( -0.96538587902213, 0.00988437503832) -( 2,-3):( 0.96538587902213, 0.00988437503832) - -&sech -(-2.0,0):( 0.26580222883408, 0 ) -(-1.0,0):( 0.64805427366389, 0 ) -(-0.5,0):( 0.88681888397007, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.88681888397007, 0 ) -( 1.0,0):( 0.64805427366389, 0 ) -( 2.0,0):( 0.26580222883408, 0 ) - -&sech -( 2, 3):( -0.26351297515839, -0.03621163655877) -(-2, 3):( -0.26351297515839, 0.03621163655877) -(-2,-3):( -0.26351297515839, -0.03621163655877) -( 2,-3):( -0.26351297515839, 0.03621163655877) - -&csch -(-2.0,0):( -0.27572056477178, 0 ) -(-1.0,0):( -0.85091812823932, 0 ) -(-0.5,0):( -1.91903475133494, 0 ) -( 0.5,0):( 1.91903475133494, 0 ) -( 1.0,0):( 0.85091812823932, 0 ) -( 2.0,0):( 0.27572056477178, 0 ) - -&csch -( 2, 3):( -0.27254866146294, -0.04030057885689) -(-2, 3):( 0.27254866146294, -0.04030057885689) -(-2,-3):( 0.27254866146294, 0.04030057885689) -( 2,-3):( -0.27254866146294, 0.04030057885689) - -&coth -(-2.0,0):( -1.03731472072755, 0 ) -(-1.0,0):( -1.31303528549933, 0 ) -(-0.5,0):( -2.16395341373865, 0 ) -( 0.5,0):( 2.16395341373865, 0 ) -( 1.0,0):( 1.31303528549933, 0 ) -( 2.0,0):( 1.03731472072755, 0 ) - -&coth -( 2, 3):( 1.03574663776500, 0.01060478347034) -(-2, 3):( -1.03574663776500, 0.01060478347034) -(-2,-3):( -1.03574663776500, -0.01060478347034) -( 2,-3):( 1.03574663776500, -0.01060478347034) - -&asinh -(-2.0,0):( -1.44363547517881, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -0.48121182505960, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.48121182505960, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 1.44363547517881, 0 ) - -&asinh -( 2, 3):( 1.96863792579310, 0.96465850440760) -(-2, 3):( -1.96863792579310, 0.96465850440761) -(-2,-3):( -1.96863792579310, -0.96465850440761) -( 2,-3):( 1.96863792579310, -0.96465850440760) - -&acosh -(-2.0,0):( 1.31695789692482, 3.14159265358979) -(-1.0,0):( 0, 3.14159265358979) -(-0.5,0):( 0, 2.09439510239320) -( 0.0,0):( 0, 1.57079632679490) -( 0.5,0):( 0, 1.04719755119660) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.31695789692482, 0 ) - -&acosh -( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( 1.98338702991653, 2.14144911111600) -(-2,-3):( 1.98338702991653, -2.14144911111600) -( 2,-3):( 1.98338702991654, -1.00014354247380) - -&atanh -(-2.0,0):( -0.54930614433405, 1.57079632679490) -(-0.5,0):( -0.54930614433405, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54930614433405, 0 ) -( 2.0,0):( 0.54930614433405, 1.57079632679490) - -&atanh -( 2, 3):( 0.14694666622553, 1.33897252229449) -(-2, 3):( -0.14694666622553, 1.33897252229449) -(-2,-3):( -0.14694666622553, -1.33897252229449) -( 2,-3):( 0.14694666622553, -1.33897252229449) - -&asech -(-2.0,0):( 0 , 2.09439510239320) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( 1.31695789692482, 3.14159265358979) -( 0.5,0):( 1.31695789692482, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.04719755119660) - -&asech -( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( 0.23133469857397, -1.72118193112276) -(-2,-3):( 0.23133469857397, 1.72118193112276) -( 2,-3):( 0.23133469857397, 1.42041072246703) - -&acsch -(-2.0,0):( -0.48121182505960, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -1.44363547517881, 0 ) -( 0.5,0):( 1.44363547517881, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 0.48121182505960, 0 ) - -&acsch -( 2, 3):( 0.15735549884499, -0.22996290237721) -(-2, 3):( -0.15735549884499, -0.22996290237721) -(-2,-3):( -0.15735549884499, 0.22996290237721) -( 2,-3):( 0.15735549884499, 0.22996290237721) - -&acoth -(-2.0,0):( -0.54930614433405, 0 ) -(-0.5,0):( -0.54930614433405, 1.57079632679490) -( 0.5,0):( 0.54930614433405, 1.57079632679490) -( 2.0,0):( 0.54930614433405, 0 ) - -&acoth -( 2, 3):( 0.14694666622553, -0.23182380450040) -(-2, 3):( -0.14694666622553, -0.23182380450040) -(-2,-3):( -0.14694666622553, 0.23182380450040) -( 2,-3):( 0.14694666622553, 0.23182380450040) - -# eof diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t deleted file mode 100755 index 1822823..0000000 --- a/contrib/perl5/t/lib/db-btree.t +++ /dev/null @@ -1,1296 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use warnings; -use strict; -use DB_File; -use Fcntl; - -print "1..157\n"; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub lexical -{ - my(@a) = unpack ("C*", $a) ; - my(@b) = unpack ("C*", $b) ; - - my $len = (@a > @b ? @b : @a) ; - my $i = 0 ; - - foreach $i ( 0 .. $len -1) { - return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; - } - - return @a - @b ; -} - -{ - 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 $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); - -my $Dfile = "dbbtree.tmp"; -unlink $Dfile; - -umask(0); - -# Check the interface to BTREEINFO - -my $dbh = new DB_File::BTREEINFO ; -ok(1, ! defined $dbh->{flags}) ; -ok(2, ! defined $dbh->{cachesize}) ; -ok(3, ! defined $dbh->{psize}) ; -ok(4, ! defined $dbh->{lorder}) ; -ok(5, ! defined $dbh->{minkeypage}) ; -ok(6, ! defined $dbh->{maxkeypage}) ; -ok(7, ! defined $dbh->{compare}) ; -ok(8, ! defined $dbh->{prefix}) ; - -$dbh->{flags} = 3000 ; -ok(9, $dbh->{flags} == 3000) ; - -$dbh->{cachesize} = 9000 ; -ok(10, $dbh->{cachesize} == 9000); - -$dbh->{psize} = 400 ; -ok(11, $dbh->{psize} == 400) ; - -$dbh->{lorder} = 65 ; -ok(12, $dbh->{lorder} == 65) ; - -$dbh->{minkeypage} = 123 ; -ok(13, $dbh->{minkeypage} == 123) ; - -$dbh->{maxkeypage} = 1234 ; -ok(14, $dbh->{maxkeypage} == 1234 ); - -$dbh->{compare} = 1234 ; -ok(15, $dbh->{compare} == 1234) ; - -$dbh->{prefix} = 1234 ; -ok(16, $dbh->{prefix} == 1234 ); - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; -eval 'my $q = $dbh->{fred}' ; -ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; - -# Now check the interface to BTREE - -my ($X, %h) ; -ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(21, !$i ) ; - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(22, $h{'abc'} eq 'ABC' ); -ok(23, ! defined $h{'jimmy'} ) ; -ok(24, ! exists $h{'jimmy'} ) ; -ok(25, defined $h{'abc'} ) ; - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - -# tie to the same file again -ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(27, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(28, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(29, $#keys == 31) ; - -#Check that the keys can be retrieved in order -my @b = keys %h ; -my @c = sort lexical @b ; -ok(30, ArrayCompare(\@b, \@c)) ; - -$h{'foo'} = ''; -ok(31, $h{'foo'} eq '' ) ; - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(32, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(33, $ok); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(34, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(35, join(':',200..400) eq join(':',@foo) ); - -# Now check all the non-tie specific stuff - - -# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(36, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(37, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(38, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(39, $status == 0 ); -ok(40, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(41, $status == 0 ); -if ($null_keys_allowed) { - $status = $X->del('') ; -} else { - $status = 0 ; -} -ok(42, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -ok(43, ! defined $h{'q'}) ; -ok(44, ! defined $h{''}) ; - -undef $X ; -untie %h ; - -ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(46, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(47, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(48, $status == 0 ); -ok(49, $value eq 'A' ); - -# seq -# ### - -# use seq to find an approximate match -$key = 'ke' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(50, $status == 0 ); -ok(51, $key eq 'key' ); -ok(52, $value eq 'value' ); - -# seq when the key does not match -$key = 'zzz' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(53, $status == 1 ); - - -# use seq to set the cursor, then delete the record @ the cursor. - -$key = 'x' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(54, $status == 0 ); -ok(55, $key eq 'x' ); -ok(56, $value eq 'X' ); -$status = $X->del(0, R_CURSOR) ; -ok(57, $status == 0 ); -$status = $X->get('x', $value) ; -ok(58, $status == 1 ); - -# ditto, but use put to replace the key/value pair. -$key = 'y' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(59, $status == 0 ); -ok(60, $key eq 'y' ); -ok(61, $value eq 'Y' ); - -$key = "replace key" ; -$value = "replace value" ; -$status = $X->put($key, $value, R_CURSOR) ; -ok(62, $status == 0 ); -ok(63, $key eq 'replace key' ); -ok(64, $value eq 'replace value' ); -$status = $X->get('y', $value) ; -ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) - # only worked because of a bug in 1.85/6 - -# use seq to walk forwards through a file - -$status = $X->seq($key, $value, R_FIRST) ; -ok(66, $status == 0 ); -my $previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_NEXT)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == 1 ; -} - -ok(67, $status == 1 ); -ok(68, $ok == 1 ); - -# use seq to walk backwards through a file -$status = $X->seq($key, $value, R_LAST) ; -ok(69, $status == 0 ); -$previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_PREV)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == -1 ; - #print "key = [$key] value = [$value]\n" ; -} - -ok(70, $status == 1 ); -ok(71, $ok == 1 ); - - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(72, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(73, $status != 0 ); - - -undef $X ; -untie %h ; - -unlink $Dfile; - -# Now try an in memory file -my $Y; -ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); - -# fd with an in memory file should return failure -$status = $Y->fd ; -ok(75, $status == -1 ); - - -undef $Y ; -untie %h ; - -# Duplicate keys -my $bt = new DB_File::BTREEINFO ; -$bt->{flags} = R_DUP ; -my ($YY, %hh); -ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; - -$hh{'Wall'} = 'Larry' ; -$hh{'Wall'} = 'Stone' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value -$hh{'Smith'} = 'John' ; -$hh{'mouse'} = 'mickey' ; - -# first work in scalar context -ok(77, scalar $YY->get_dup('Unknown') == 0 ); -ok(78, scalar $YY->get_dup('Smith') == 1 ); -ok(79, scalar $YY->get_dup('Wall') == 4 ); - -# now in list context -my @unknown = $YY->get_dup('Unknown') ; -ok(80, "@unknown" eq "" ); - -my @smith = $YY->get_dup('Smith') ; -ok(81, "@smith" eq "John" ); - -{ -my @wall = $YY->get_dup('Wall') ; -my %wall ; -@wall{@wall} = @wall ; -ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); -} - -# hash -my %unknown = $YY->get_dup('Unknown', 1) ; -ok(83, keys %unknown == 0 ); - -my %smith = $YY->get_dup('Smith', 1) ; -ok(84, keys %smith == 1 && $smith{'John'}) ; - -my %wall = $YY->get_dup('Wall', 1) ; -ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 - && $wall{'Brick'} == 2); - -undef $YY ; -untie %hh ; -unlink $Dfile; - - -# test multiple callbacks -my $Dfile1 = "btree1" ; -my $Dfile2 = "btree2" ; -my $Dfile3 = "btree3" ; - -my $dbh1 = new DB_File::BTREEINFO ; -$dbh1->{compare} = sub { - no warnings 'numeric' ; - $_[0] <=> $_[1] } ; - -my $dbh2 = new DB_File::BTREEINFO ; -$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; - -my $dbh3 = new DB_File::BTREEINFO ; -$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; - - -my (%g, %k); -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; -tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; -tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; - -my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; -my (@srt_1, @srt_2, @srt_3); -{ - no warnings 'numeric' ; - @srt_1 = sort { $a <=> $b } @Keys ; -} -@srt_2 = sort { $a cmp $b } @Keys ; -@srt_3 = sort { length $a <=> length $b } @Keys ; - -foreach (@Keys) { - $h{$_} = 1 ; - $g{$_} = 1 ; - $k{$_} = 1 ; -} - -sub ArrayCompare -{ - my($a, $b) = @_ ; - - return 0 if @$a != @$b ; - - foreach (1 .. length @$a) - { - return 0 unless $$a[$_] eq $$b[$_] ; - } - - 1 ; -} - -ok(86, ArrayCompare (\@srt_1, [keys %h]) ); -ok(87, ArrayCompare (\@srt_2, [keys %g]) ); -ok(88, ArrayCompare (\@srt_3, [keys %k]) ); - -untie %h ; -untie %g ; -untie %k ; -unlink $Dfile1, $Dfile2, $Dfile3 ; - -# clear -# ##### - -ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(90, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(91, $i == 0); - -untie %h ; -unlink $Dfile1 ; - -{ - # check that attempting to tie an array to a DB_BTREE will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; - ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(93, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); - ' ; - - main::ok(94, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(95, $@ eq "") ; - main::ok(96, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(97, $@ eq "") ; - main::ok(98, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(99, $@ eq "" ) ; - main::ok(100, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(101, $@ eq "") ; - main::ok(102, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - 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 warnings ; - 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 warnings ; - 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 warnings FATAL => qw(all) ; - 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 warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename %h ) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the associative array - # and print each key/value pair. - foreach (keys %h) - { print "$_ -> $h{$_}\n" } - - untie %h ; - - unlink $filename ; - } - - ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Larry -Wall -> Larry -mouse -> mickey -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 3 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $status $key $value) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the btree using seq - # and print each key/value pair. - $key = $value = 0 ; - for ($status = $x->seq($key, $value, R_FIRST) ; - $status == 0 ; - $status = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } - - - undef $x ; - untie %h ; - } - - ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Larry -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM - - - { - my $redirect = new Redirect $file ; - - # BTREE example 4 - ### - - use warnings FATAL => qw(all) ; - 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 warnings FATAL => qw(all) ; - 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 warnings FATAL => qw(all) ; - 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 warnings FATAL => qw(all) ; - 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; -#} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(156, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - %h = (); ; - ok(157, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t deleted file mode 100755 index effc60b..0000000 --- a/contrib/perl5/t/lib/db-hash.t +++ /dev/null @@ -1,743 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; -use DB_File; -use Fcntl; - -print "1..111\n"; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -{ - 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"; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); - -unlink $Dfile; - -umask(0); - -# Check the interface to HASHINFO - -my $dbh = new DB_File::HASHINFO ; - -ok(1, ! defined $dbh->{bsize}) ; -ok(2, ! defined $dbh->{ffactor}) ; -ok(3, ! defined $dbh->{nelem}) ; -ok(4, ! defined $dbh->{cachesize}) ; -ok(5, ! defined $dbh->{hash}) ; -ok(6, ! defined $dbh->{lorder}) ; - -$dbh->{bsize} = 3000 ; -ok(7, $dbh->{bsize} == 3000 ); - -$dbh->{ffactor} = 9000 ; -ok(8, $dbh->{ffactor} == 9000 ); - -$dbh->{nelem} = 400 ; -ok(9, $dbh->{nelem} == 400 ); - -$dbh->{cachesize} = 65 ; -ok(10, $dbh->{cachesize} == 65 ); - -$dbh->{hash} = "abc" ; -ok(11, $dbh->{hash} eq "abc" ); - -$dbh->{lorder} = 1234 ; -ok(12, $dbh->{lorder} == 1234 ); - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); -eval 'my $q = $dbh->{fred}' ; -ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); - - -# Now check the interface to HASH -my ($X, %h); -ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(17, !$i ); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(18, $h{'abc'} eq 'ABC' ); -ok(19, !defined $h{'jimmy'} ); -ok(20, !exists $h{'jimmy'} ); -ok(21, exists $h{'abc'} ); - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - - -# tie to the same file again, do not supply a type - should default to HASH -ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(23, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(24, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(25, $#keys == 31) ; - -$h{'foo'} = ''; -ok(26, $h{'foo'} eq '' ); - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(27, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(28, $ok ); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(29, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(30, join(':',200..400) eq join(':',@foo) ); - - -# Now check all the non-tie specific stuff - -# Check NOOVERWRITE will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(31, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(32, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(33, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(34, $status == 0 ); -ok(35, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(36, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -{ - no warnings 'uninitialized' ; - ok(37, $h{'q'} eq undef ); -} - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(38, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(39, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(40, $status == 0 ); -ok(41, $value eq 'A' ); - -# seq -# ### - -# ditto, but use put to replace the key/value pair. - -# use seq to walk backwards through a file - check that this reversed is - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(42, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(43, $status != 0 ); - -undef $X ; -untie %h ; - -unlink $Dfile; - -# clear -# ##### - -ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(45, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(46, $i == 0); - -untie %h ; -unlink $Dfile ; - - -# Now try an in memory file -ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - -# fd with an in memory file should return fail -$status = $X->fd ; -ok(48, $status == -1 ); - -undef $X ; -untie %h ; - -{ - # check ability to override the default hashing - my %x ; - my $filename = "xyz" ; - my $hi = new DB_File::HASHINFO ; - $::count = 0 ; - $hi->{hash} = sub { ++$::count ; length $_[0] } ; - ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; - $h{"abc"} = 123 ; - ok(50, $h{"abc"} == 123) ; - untie %x ; - unlink $filename ; - ok(51, $::count >0) ; -} - -{ - # check that attempting to tie an array to a DB_HASH will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; - ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(53, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); - ' ; - - main::ok(54, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(55, $@ eq "") ; - main::ok(56, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(57, $@ eq "") ; - main::ok(58, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(59, $@ eq "" ) ; - main::ok(60, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbhash.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - 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 warnings ; - 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 warnings ; - 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 warnings FATAL => qw(all); - 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 - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(110, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - %h = (); ; - ok(111, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t deleted file mode 100755 index 8b5a88c..0000000 --- a/contrib/perl5/t/lib/db-recno.t +++ /dev/null @@ -1,889 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use DB_File; -use Fcntl; -use strict ; -use warnings; -use vars qw($dbh $Dfile $bad_ones $FA) ; - -# full tied array support started in Perl 5.004_57 -# Double check to see if it is available. - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; - - 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 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 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..128\n"; - -my $Dfile = "recno.tmp"; -unlink $Dfile ; - -umask(0); - -# Check the interface to RECNOINFO - -my $dbh = new DB_File::RECNOINFO ; -ok(1, ! defined $dbh->{bval}) ; -ok(2, ! defined $dbh->{cachesize}) ; -ok(3, ! defined $dbh->{psize}) ; -ok(4, ! defined $dbh->{flags}) ; -ok(5, ! defined $dbh->{lorder}) ; -ok(6, ! defined $dbh->{reclen}) ; -ok(7, ! defined $dbh->{bfname}) ; - -$dbh->{bval} = 3000 ; -ok(8, $dbh->{bval} == 3000 ); - -$dbh->{cachesize} = 9000 ; -ok(9, $dbh->{cachesize} == 9000 ); - -$dbh->{psize} = 400 ; -ok(10, $dbh->{psize} == 400 ); - -$dbh->{flags} = 65 ; -ok(11, $dbh->{flags} == 65 ); - -$dbh->{lorder} = 123 ; -ok(12, $dbh->{lorder} == 123 ); - -$dbh->{reclen} = 1234 ; -ok(13, $dbh->{reclen} == 1234 ); - -$dbh->{bfname} = 1234 ; -ok(14, $dbh->{bfname} == 1234 ); - - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); -eval 'my $q = $dbh->{fred}' ; -ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); - -# Now check the interface to RECNOINFO - -my $X ; -my @h ; -ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; - -ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) - || $^O eq 'MSWin32' || $^O eq 'amigaos') ; - -#my $l = @h ; -my $l = $X->length ; -ok(19, ($FA ? @h == 0 : !$l) ); - -my @data = qw( a b c d ever f g h i j k longername m n o p) ; - -$h[0] = shift @data ; -ok(20, $h[0] eq 'a' ); - -my $ i; -foreach (@data) - { $h[++$i] = $_ } - -unshift (@data, 'a') ; - -ok(21, defined $h[1] ); -ok(22, ! defined $h[16] ); -ok(23, $FA ? @h == @data : $X->length == @data ); - - -# Overwrite an entry & check fetch it -$h[3] = 'replaced' ; -$data[3] = 'replaced' ; -ok(24, $h[3] eq 'replaced' ); - -#PUSH -my @push_data = qw(added to the end) ; -($FA ? push(@h, @push_data) : $X->push(@push_data)) ; -push (@data, @push_data) ; -ok(25, $h[++$i] eq 'added' ); -ok(26, $h[++$i] eq 'to' ); -ok(27, $h[++$i] eq 'the' ); -ok(28, $h[++$i] eq 'end' ); - -# POP -my $popped = pop (@data) ; -my $value = ($FA ? pop @h : $X->pop) ; -ok(29, $value eq $popped) ; - -# SHIFT -$value = ($FA ? shift @h : $X->shift) ; -my $shifted = shift @data ; -ok(30, $value eq $shifted ); - -# UNSHIFT - -# empty list -($FA ? unshift @h : $X->unshift) ; -ok(31, ($FA ? @h == @data : $X->length == @data )); - -my @new_data = qw(add this to the start of the array) ; -$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; -unshift (@data, @new_data) ; -ok(32, $FA ? @h == @data : $X->length == @data ); -ok(33, $h[0] eq "add") ; -ok(34, $h[1] eq "this") ; -ok(35, $h[2] eq "to") ; -ok(36, $h[3] eq "the") ; -ok(37, $h[4] eq "start") ; -ok(38, $h[5] eq "of") ; -ok(39, $h[6] eq "the") ; -ok(40, $h[7] eq "array") ; -ok(41, $h[8] eq $data[8]) ; - -# SPLICE - -# Now both arrays should be identical - -my $ok = 1 ; -my $j = 0 ; -foreach (@data) -{ - $ok = 0, last if $_ ne $h[$j ++] ; -} -ok(42, $ok ); - -# Neagtive subscripts - -# get the last element of the array -ok(43, $h[-1] eq $data[-1] ); -ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); - -# get the first element using a negative subscript -eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; -ok(45, $@ eq "" ); -ok(46, $h[0] eq "abcd" ); - -# now try to read before the start of the array -eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; -ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(@h); - -unlink $Dfile; - - -{ - # Check bval defaults to \n - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - ok(49, $x eq "abc\ndef\n\nghi\n") ; -} - -{ - # Change bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{bval} = "-" ; - ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc-def--ghi-") ; - bad_one() unless $ok ; - ok(51, $ok) ; -} - -{ - # Check R_FIXEDLEN with default bval (space) - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{reclen} = 5 ; - ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc def ghi ") ; - bad_one() unless $ok ; - ok(53, $ok) ; -} - -{ - # Check R_FIXEDLEN with user-defined bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{bval} = "-" ; - $dbh->{reclen} = 5 ; - ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc--def-------ghi--") ; - bad_one() unless $ok ; - ok(55, $ok) ; -} - -{ - # check that attempting to tie an associative array to a DB_RECNO will fail - - my $filename = "xyz" ; - my %x ; - eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; - ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(57, $@ eq "") ; - my @h ; - my $X ; - eval ' - $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); - ' ; - - main::ok(58, $@ eq "") ; - - my $ret = eval '$h[3] = 3 ; return $h[3] ' ; - main::ok(59, $@ eq "") ; - main::ok(60, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(63, $@ eq "" ) ; - main::ok(64, $ret == 1) ; - - $ret = eval '$X->A_new_method(1) ' ; - main::ok(65, $@ eq "") ; - main::ok(66, $ret eq "[[11]]") ; - - undef $X; - untie(@h); - unlink "SubDB.pm", "recno.tmp" ; - -} - -{ - - # test $# - my $self ; - unlink $Dfile; - ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[2] = "ghi" ; - $h[3] = "jkl" ; - ok(68, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - my $x = docat($Dfile) ; - ok(69, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to same length - ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 3 } - else - { $self->STORESIZE(4) } - ok(71, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(72, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to bigger - ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 6 } - else - { $self->STORESIZE(7) } - ok(74, $FA ? $#h == 6 : $self->length() == 7) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; - - # $# sets array smaller - ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 2 } - else - { $self->STORESIZE(3) } - ok(77, $FA ? $#h == 2 : $self->length() == 3) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(78, $x eq "abc\ndef\nghi\n") ; - - unlink $Dfile; - - -} - -{ - # DBM Filter tests - use warnings ; - 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 warnings ; - 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 warnings ; - 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 warnings FATAL => qw(all); - 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 warnings FATAL => qw(all); - 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 - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my @h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - $h[0] = undef; - ok(127, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - unlink $Dfile; - my @h ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - @h = (); ; - ok(128, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t deleted file mode 100755 index aa7be35..0000000 --- a/contrib/perl5/t/lib/dirhand.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -use DirHandle; - -print "1..5\n"; - -$dot = new DirHandle "."; -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"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t deleted file mode 100755 index fd9bb1d..0000000 --- a/contrib/perl5/t/lib/dosglob.t +++ /dev/null @@ -1,112 +0,0 @@ -#!./perl - -# -# test glob() in File::DosGlob -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..10\n"; - -# override it in main:: -use File::DosGlob 'glob'; - -# test if $_ takes as the default -$_ = "lib/a*.t"; -my @r = glob; -print "not " if $_ ne 'lib/a*.t'; -print "ok 1\n"; -# we should have at least abbrev.t, anydbm.t, autoloader.t -print "# |@r|\nnot " if @r < 3; -print "ok 2\n"; - -# check if <*/*> works -@r = <*/a*.t>; -# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t -print "not " if @r < 9; -print "ok 3\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -while (defined($_ = <*/a*.t>)) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 4\n"; - -# check if list context works -@r = (); -for (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 5\n"; - -# test if implicit assign to $_ in while() works -@r = (); -while (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 7\n"; - -# how about in a different package, like? -package Foo; -use File::DosGlob 'glob'; -@s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# test if different glob ops maintain independent contexts -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (<*/b*.t>) { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# how about a global override, hm? -eval <<'EOT'; -use File::DosGlob 'GLOBAL_glob'; -package Bar; -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (glob '*/b*.t') { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 10\n"; -EOT diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t deleted file mode 100755 index be711f1..0000000 --- a/contrib/perl5/t/lib/dprof.t +++ /dev/null @@ -1,88 +0,0 @@ -#!perl - -BEGIN { - chdir( 't' ) if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ - print "1..0 # Skip: Devel::DProf was not built\n"; - exit 0; - } -} - -END { - while(-e 'tmon.out' && unlink 'tmon.out') {} - while(-e 'err' && unlink 'err') {} -} - -use Benchmark qw( timediff timestr ); -use Getopt::Std 'getopts'; -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; - - my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; - $command .= ' -v' if $opt_v; - $command .= ' -p '. $perl; - system $command; -} - - -$| = 1; -print "1..18\n"; -while( @tests ){ - $test = shift @tests; - $test =~ s/\.$// if $^O eq 'VMS'; - if( $test =~ /_t$/i ){ - print "# $test" . '.' x (20 - length $test); - profile $test; - } - else{ - verify $test; - } -} - -unlink("tmon.out"); diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm deleted file mode 100644 index 152cddc..0000000 --- a/contrib/perl5/t/lib/dprof/V.pm +++ /dev/null @@ -1,63 +0,0 @@ -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'; -$dpp .= '.com' if $^O eq 'VMS'; - -print "\nperl: $perl\n" if $opt_v; -if( ! -f $perl ){ die "Where's Perl?" } -if( ! -f $dpp ) { - ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@; - die "Where's dprofpp?" if( ! -f $dpp ); -} - -sub dprofpp { - my $switches = shift; - - open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n"; - @results = <D>; - close D; - - open( D, "<err" ) || warn "$0: Can't open: $!\n"; - @err = <D>; - close D; - push( @results, @err ) if @err; - - $results = qq{@results}; - # ignore Loader (Dyna/Auto etc), leave newline - $results =~ s/^\w+Loader::import//; - $results =~ s/\n /\n/gm; - $results; -} - -sub report { - $num = shift; - my $sub = shift; - my $x; - - $x = &$sub; - $x ? &ok : ¬ok; -} - -sub ok { - print "ok $num\n"; -} - -sub notok { - print "not ok $num\n"; - print "\nResult\n{$results}\n"; - print "Expected\n{$expected}\n"; -} - -1; diff --git a/contrib/perl5/t/lib/dprof/test1_t b/contrib/perl5/t/lib/dprof/test1_t deleted file mode 100644 index d504cd5..0000000 --- a/contrib/perl5/t/lib/dprof/test1_t +++ /dev/null @@ -1,18 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - foo(); -} - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test1_v b/contrib/perl5/t/lib/dprof/test1_v deleted file mode 100644 index 542a503..0000000 --- a/contrib/perl5/t/lib/dprof/test1_v +++ /dev/null @@ -1,24 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::baz - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 1, sub { $expected eq $results }; - -dprofpp('-TF'); -report 2, sub { $expected eq $results }; - -dprofpp( '-t' ); -report 3, sub { $expected eq $results }; - -dprofpp('-tF'); -report 4, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test2_t b/contrib/perl5/t/lib/dprof/test2_t deleted file mode 100644 index edc46c5..0000000 --- a/contrib/perl5/t/lib/dprof/test2_t +++ /dev/null @@ -1,21 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - bar(); - bar(); - foo(); -} - -bar(); -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test2_v b/contrib/perl5/t/lib/dprof/test2_v deleted file mode 100644 index 8b775b3..0000000 --- a/contrib/perl5/t/lib/dprof/test2_v +++ /dev/null @@ -1,36 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::bar -main::baz - main::bar - main::bar - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 5, sub { $expected eq $results }; - -dprofpp('-TF'); -report 6, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = -qq{main::bar (2x) -main::baz - main::bar (3x) - main::foo - main::bar -main::foo - main::bar -}; -report 7, sub { $expected eq $results }; - -dprofpp('-tF'); -report 8, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test3_t b/contrib/perl5/t/lib/dprof/test3_t deleted file mode 100644 index a5327f4..0000000 --- a/contrib/perl5/t/lib/dprof/test3_t +++ /dev/null @@ -1,19 +0,0 @@ -sub foo { - print "in sub foo\n"; - exit(0); - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - foo(); -} - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test3_v b/contrib/perl5/t/lib/dprof/test3_v deleted file mode 100644 index df7543e..0000000 --- a/contrib/perl5/t/lib/dprof/test3_v +++ /dev/null @@ -1,29 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$e1 = $expected = -qq{main::bar -main::baz - main::bar - main::foo -}; -report 9, sub { $expected eq $results }; - -dprofpp('-TF'); -$e2 = $expected = -qq{main::bar -main::baz - main::bar - main::foo -}; -report 10, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = $e1; -report 11, sub { 1 }; - -dprofpp('-tF'); -$expected = $e2; -report 12, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test4_t b/contrib/perl5/t/lib/dprof/test4_t deleted file mode 100644 index 7299682..0000000 --- a/contrib/perl5/t/lib/dprof/test4_t +++ /dev/null @@ -1,24 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - bar(); - bar(); - foo(); -} - -bar(); - -eval { fork }; - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test4_v b/contrib/perl5/t/lib/dprof/test4_v deleted file mode 100644 index d9677ff..0000000 --- a/contrib/perl5/t/lib/dprof/test4_v +++ /dev/null @@ -1,36 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::bar -main::baz - main::bar - main::bar - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 13, sub { $expected eq $results }; - -dprofpp('-TF'); -report 14, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = -qq{main::bar (2x) -main::baz - main::bar (3x) - main::foo - main::bar -main::foo - main::bar -}; -report 15, sub { $expected eq $results }; - -dprofpp('-tF'); -report 16, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test5_t b/contrib/perl5/t/lib/dprof/test5_t deleted file mode 100644 index 0b11137..0000000 --- a/contrib/perl5/t/lib/dprof/test5_t +++ /dev/null @@ -1,25 +0,0 @@ -# Test that dprof doesn't break -# &bar; used as &bar(@_); - -sub foo1 { - print "in foo1(@_)\n"; - bar(@_); -} -sub foo2 { - print "in foo2(@_)\n"; - &bar; -} -sub bar { - print "in bar(@_)\n"; - if( @_ > 0 ){ - &yeppers; - } -} -sub yeppers { - print "rest easy\n"; -} - - -&foo1( A ); -&foo2( B ); - diff --git a/contrib/perl5/t/lib/dprof/test5_v b/contrib/perl5/t/lib/dprof/test5_v deleted file mode 100644 index 9e9298c..0000000 --- a/contrib/perl5/t/lib/dprof/test5_v +++ /dev/null @@ -1,15 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::foo1 - main::bar - main::yeppers -main::foo2 - main::bar - main::yeppers -}; -report 17, sub { $expected eq $results }; - diff --git a/contrib/perl5/t/lib/dprof/test6_t b/contrib/perl5/t/lib/dprof/test6_t deleted file mode 100644 index 7b8bf4a..0000000 --- a/contrib/perl5/t/lib/dprof/test6_t +++ /dev/null @@ -1,29 +0,0 @@ -sub foo { - my $x; - my $y; - print "in sub foo\n"; - for( $x = 1; $x < 100; ++$x ){ - bar(); - for( $y = 1; $y < 100; ++$y ){ - } - } -} - -sub bar { - my $x; - print "in sub bar\n"; - for( $x = 1; $x < 100; ++$x ){ - } - die "bar exiting"; -} - -sub baz { - print "in sub baz\n"; - eval { bar(); }; - eval { foo(); }; -} - -eval { bar(); }; -baz(); -eval { foo(); }; - diff --git a/contrib/perl5/t/lib/dprof/test6_v b/contrib/perl5/t/lib/dprof/test6_v deleted file mode 100644 index 2f651ea..0000000 --- a/contrib/perl5/t/lib/dprof/test6_v +++ /dev/null @@ -1,16 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::baz - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 18, sub { $expected eq $results }; - diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t deleted file mode 100755 index d4b3a92..0000000 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; - -print "1..1\n"; - -package Foo; -use overload '""' => 'as_string'; - -sub new { bless { foo => "bar" }, shift } -sub as_string { "%%%%" } - -package main; - -my $f = Foo->new; - -print "#\$f=$f\n"; - -$_ = Dumper($f); -s/^/#/mg; -print $_; - -print "not " unless /bar/ && /Foo/; -print "ok 1\n"; - diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t deleted file mode 100755 index be9732f..0000000 --- a/contrib/perl5/t/lib/dumper.t +++ /dev/null @@ -1,810 +0,0 @@ -#!./perl -w -# -# testsuite for Data::Dumper -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; -use Config; -my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; - -$Data::Dumper::Pad = "#"; -my $TMAX; -my $XS; -my $TNUM = 0; -my $WANT = ''; - -sub TEST { - my $string = shift; - my $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # these data need massaging with non ascii character sets - # because of hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); - - ++$TNUM; - eval "$t"; - print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; - - $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # here too there are hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); -} - -if (defined &Data::Dumper::Dumpxs) { - print "### XS extension loaded, will run XS tests\n"; - $TMAX = 186; $XS = 1; -} -else { - print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 93; $XS = 0; -} - -print "1..$TMAX\n"; - -############# -############# - -@c = ('c'); -$c = \@c; -$b = {}; -$a = [1, $b, $c]; -$b->{a} = $a; -$b->{b} = $a->[1]; -$b->{c} = $a->[2]; - -############# 1 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'a' => $a, -# 'b' => $a->[1], -# 'c' => [ -# 'c' -# ] -# }, -# $a->[1]{'c'} -# ]; -#$b = $a->[1]; -#$c = $a->[1]{'c'}; -EOT - -TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)])); -TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS; - - -############# 7 -## -$WANT = <<'EOT'; -#@a = ( -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [ -# 'c' -# ] -# }, -# [] -# ); -#$a[1]{'a'} = \@a; -#$a[1]{'b'} = $a[1]; -#$a[2] = $a[1]{'c'}; -#$b = $a[1]; -EOT - -$Data::Dumper::Purity = 1; # fill in the holes for eval -TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a -TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS; - -############# 13 -## -$WANT = <<'EOT'; -#%b = ( -# 'a' => [ -# 1, -# {}, -# [ -# 'c' -# ] -# ], -# 'b' => {}, -# 'c' => [] -# ); -#$b{'a'}[1] = \%b; -#$b{'b'} = \%b; -#$b{'c'} = $b{'a'}[2]; -#$a = $b{'a'}; -EOT - -TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b -TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS; - -############# 19 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [] -# }, -# [] -#]; -#$a->[1]{'a'} = $a; -#$a->[1]{'b'} = $a->[1]; -#$a->[1]{'c'} = \@c; -#$a->[2] = \@c; -#$b = $a->[1]; -EOT - -$Data::Dumper::Indent = 1; -TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dump; - ); -if ($XS) { - TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dumpxs; - ); -} - - -############# 25 -## -$WANT = <<'EOT'; -#$a = [ -# #0 -# 1, -# #1 -# { -# a => $a, -# b => $a->[1], -# c => [ -# #0 -# 'c' -# ] -# }, -# #2 -# $a->[1]{c} -# ]; -#$b = $a->[1]; -EOT - -$d->Indent(3); -$d->Purity(0)->Quotekeys(0); -TEST q( $d->Reset; $d->Dump ); - -TEST q( $d->Reset; $d->Dumpxs ) if $XS; - -############# 31 -## -$WANT = <<'EOT'; -#$VAR1 = [ -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [ -# 'c' -# ] -# }, -# [] -#]; -#$VAR1->[1]{'a'} = $VAR1; -#$VAR1->[1]{'b'} = $VAR1->[1]; -#$VAR1->[2] = $VAR1->[1]{'c'}; -EOT - -TEST q(Dumper($a)); -TEST q(Data::Dumper::DumperX($a)) if $XS; - -############# 37 -## -$WANT = <<'EOT'; -#[ -# 1, -# { -# a => $VAR1, -# b => $VAR1->[1], -# c => [ -# 'c' -# ] -# }, -# $VAR1->[1]{c} -#] -EOT - -{ - local $Data::Dumper::Purity = 0; - local $Data::Dumper::Quotekeys = 0; - local $Data::Dumper::Terse = 1; - TEST q(Dumper($a)); - TEST q(Data::Dumper::DumperX($a)) if $XS; -} - - -############# 43 -## -$WANT = <<'EOT'; -#$VAR1 = { -# "abc\0'\efg" => "mno\0", -# "reftest" => \\1 -#}; -EOT - -$foo = { "abc\000\'\efg" => "mno\000", - "reftest" => \\1, - }; -{ - local $Data::Dumper::Useqq = 1; - TEST q(Dumper($foo)); -} - - $WANT = <<"EOT"; -#\$VAR1 = { -# 'abc\0\\'\efg' => 'mno\0', -# 'reftest' => \\\\1 -#}; -EOT - - { - local $Data::Dumper::Useqq = 1; - TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat - } - - - -############# -############# - -{ - package main; - use Data::Dumper; - $foo = 5; - @foo = (-10,\*foo); - %foo = (a=>1,b=>\$foo,c=>\@foo); - $foo{d} = \%foo; - $foo[2] = \%foo; - -############# 49 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# #0 -# -10, -# #1 -# do{my $o}, -# #2 -# { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -# } -# ]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#@bar = @{*::foo{ARRAY}}; -#%baz = %{*::foo{ARRAY}->[2]}; -EOT - - $Data::Dumper::Purity = 1; - $Data::Dumper::Indent = 3; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 55 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# -10, -# do{my $o}, -# { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -# } -#]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#$bar = *::foo{ARRAY}; -#$baz = *::foo{ARRAY}->[2]; -EOT - - $Data::Dumper::Indent = 1; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -############# 61 -## - $WANT = <<'EOT'; -#@bar = ( -# -10, -# \*::foo, -# {} -#); -#*::foo = \5; -#*::foo = \@bar; -#*::foo = { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -#}; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'c'} = \@bar; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar[2] = *::foo{HASH}; -#%baz = %{*::foo{HASH}}; -#$foo = $bar[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS; - -############# 67 -## - $WANT = <<'EOT'; -#$bar = [ -# -10, -# \*::foo, -# {} -#]; -#*::foo = \5; -#*::foo = $bar; -#*::foo = { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -#}; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'c'} = $bar; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar->[2] = *::foo{HASH}; -#$baz = *::foo{HASH}; -#$foo = $bar->[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS; - -############# 73 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#@bar = ( -# -10, -# $foo, -# { -# a => 1, -# b => \5, -# c => \@bar, -# d => $bar[2] -# } -#); -#%baz = %{$bar[2]}; -EOT - - $Data::Dumper::Purity = 0; - $Data::Dumper::Quotekeys = 0; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 79 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#$bar = [ -# -10, -# $foo, -# { -# a => 1, -# b => \5, -# c => $bar, -# d => $bar->[2] -# } -#]; -#$baz = $bar->[2]; -EOT - - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -} - -############# -############# -{ - package main; - @dogs = ( 'Fido', 'Wags' ); - %kennel = ( - First => \$dogs[0], - Second => \$dogs[1], - ); - $dogs[2] = \%kennel; - $mutts = \%kennel; - $mutts = $mutts; # avoid warning - -############# 85 -## - $WANT = <<'EOT'; -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dumpxs; - ); - } - -############# 91 -## - $WANT = <<'EOT'; -#%kennels = %kennels; -#@dogs = @dogs; -#%mutts = %kennels; -EOT - - TEST q($d->Dump); - TEST q($d->Dumpxs) if $XS; - -############# 97 -## - $WANT = <<'EOT'; -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - - TEST q($d->Reset; $d->Dump); - if ($XS) { - TEST q($d->Reset; $d->Dumpxs); - } - -############# 103 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# First => \$dogs[0], -# Second => \$dogs[1] -# } -#); -#%kennels = %{$dogs[2]}; -#%mutts = %{$dogs[2]}; -EOT - - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dumpxs; - ); - } - -############# 109 -## - TEST q($d->Reset->Dump); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -############# 115 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# First => \'Fido', -# Second => \'Wags' -# } -#); -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -EOT - - TEST q( - $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); - $d->Deepcopy(1)->Dump; - ); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -} - -{ - -sub z { print "foo\n" } -$c = [ \&z ]; - -############# 121 -## - $WANT = <<'EOT'; -#$a = $b; -#$c = [ -# $b -#]; -EOT - -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 -## - $WANT = <<'EOT'; -#$a = \&b; -#$c = [ -# \&b -#]; -EOT - -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 -## - $WANT = <<'EOT'; -#*a = \&b; -#@c = ( -# \&b -#); -EOT - -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, -# do{my $o} -#); -#$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 => do{my $o} -# }, -# { -# 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; -} - -{ - $a = \$a; - $b = [$a]; - -############# 175 -## - $WANT = <<'EOT'; -#$b = [ -# \$b->[0] -#]; -EOT - -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) - if $XS; - -############# 181 -## - $WANT = <<'EOT'; -#$b = [ -# \do{my $o} -#]; -#${$b->[0]} = $b->[0]; -EOT - - -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) - if $XS; -} diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t deleted file mode 100755 index 0cbbdbf..0000000 --- a/contrib/perl5/t/lib/english.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -print "1..16\n"; - -BEGIN { @INC = '../lib' } -use English; -use Config; -my $threads = $Config{'use5005threads'} || 0; - -print $PID == $$ ? "ok 1\n" : "not ok 1\n"; - -$_ = 1; -print $ARG == $_ || $threads ? "ok 2\n" : "not ok 2\n"; - -sub foo { - print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n"; -} -&foo(1); - -if ($threads) { - $_ = "ok 4\nok 5\nok 6\n"; -} else { - $ARG = "ok 4\nok 5\nok 6\n"; -} -/ok 5\n/; -print $PREMATCH, $MATCH, $POSTMATCH; - -$OFS = " "; -$ORS = "\n"; -print 'ok',7; -undef $OUTPUT_FIELD_SEPARATOR; - -if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" }; -@foo = ("ok 8", "ok 9"); -print "@foo"; -undef $OUTPUT_RECORD_SEPARATOR; - -eval 'NO SUCH FUNCTION'; -print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads; - -print $UID == $< ? "ok 11\n" : "not ok 11\n"; -print $GID == $( ? "ok 12\n" : "not ok 12\n"; -print $EUID == $> ? "ok 13\n" : "not ok 13\n"; -print $EGID == $) ? "ok 14\n" : "not ok 14\n"; - -print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; -print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t deleted file mode 100755 index c5068fd..0000000 --- a/contrib/perl5/t/lib/env-array.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -$| = 1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ($^O eq 'VMS') { - print "1..11\n"; - foreach (1..11) { print "ok $_ # skipped for VMS\n"; } - exit 0; -} - -use Env qw(@FOO); -use vars qw(@BAR); - -sub array_equal -{ - my ($a, $b) = @_; - return 0 unless scalar(@$a) == scalar(@$b); - for my $i (0..scalar(@$a) - 1) { - return 0 unless $a->[$i] eq $b->[$i]; - } - return 1; -} - -sub test -{ - my ($desc, $code) = @_; - - &$code; - - print "# $desc...\n"; - print "# FOO = (", join(", ", @FOO), ")\n"; - print "# BAR = (", join(", ", @BAR), ")\n"; - - if (defined $check) { print "not " unless &$check; } - else { print "not " unless array_equal(\@FOO, \@BAR); } - - print "ok ", ++$i, "\n"; -} - -print "1..11\n"; - -test "Assignment", sub { - @FOO = qw(a B c); - @BAR = qw(a B c); -}; - -test "Storing", sub { - $FOO[1] = 'b'; - $BAR[1] = 'b'; -}; - -test "Truncation", sub { - $#FOO = 0; - $#BAR = 0; -}; - -test "Push", sub { - push @FOO, 'b', 'c'; - push @BAR, 'b', 'c'; -}; - -test "Pop", sub { - pop @FOO; - pop @BAR; -}; - -test "Shift", sub { - shift @FOO; - shift @BAR; -}; - -test "Push", sub { - push @FOO, 'c'; - push @BAR, 'c'; -}; - -test "Unshift", sub { - unshift @FOO, 'a'; - unshift @BAR, 'a'; -}; - -test "Reverse", sub { - @FOO = reverse @FOO; - @BAR = reverse @BAR; -}; - -test "Sort", sub { - @FOO = sort @FOO; - @BAR = sort @BAR; -}; - -test "Splice", sub { - splice @FOO, 1, 1, 'B'; - splice @BAR, 1, 1, 'B'; -}; diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t deleted file mode 100755 index ff6af2e..0000000 --- a/contrib/perl5/t/lib/env.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - $ENV{FOO} = "foo"; - $ENV{BAR} = "bar"; -} - -use Env qw(FOO $BAR); - -$FOO .= "/bar"; -$BAR .= "/baz"; - -print "1..2\n"; - -print "not " if $FOO ne 'foo/bar'; -print "ok 1\n"; - -print "not " if $BAR ne 'bar/baz'; -print "ok 2\n"; - diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t deleted file mode 100755 index 02f5ce2..0000000 --- a/contrib/perl5/t/lib/errno.t +++ /dev/null @@ -1,54 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '../lib'; - } - } -} - -use Errno; - -print "1..5\n"; - -print "not " unless @Errno::EXPORT_OK; -print "ok 1\n"; -die unless @Errno::EXPORT_OK; - -$err = $Errno::EXPORT_OK[0]; -$num = &{"Errno::$err"}; - -print "not " unless &{"Errno::$err"} == $num; -print "ok 2\n"; - -$! = $num; -print "not " unless $!{$err}; -print "ok 3\n"; - -$! = 0; -print "not " if $!{$err}; -print "ok 4\n"; - -$s1 = join(",",sort keys(%!)); -$s2 = join(",",sort @Errno::EXPORT_OK); - -if($s1 ne $s2) { - my @s1 = keys(%!); - my @s2 = @Errno::EXPORT_OK; - my(%s1,%s2); - @s1{@s1} = (); - @s2{@s2} = (); - delete @s2{@s1}; - delete @s1{@s2}; - print "# These are only in \%!\n"; - print "# ",join(" ",map { "'$_'" } keys %s1),"\n"; - print "# These are only in \@EXPORT_OK\n"; - print "# ",join(" ",map { "'$_'" } keys %s2),"\n"; - print "not "; -} - -print "ok 5\n"; diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t deleted file mode 100755 index f00b876..0000000 --- a/contrib/perl5/t/lib/fatal.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - print "1..15\n"; -} - -use strict; -use Fatal qw(open close :void opendir); - -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; -} - -eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " unless $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; - -eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " if $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t deleted file mode 100755 index a3f591a..0000000 --- a/contrib/perl5/t/lib/fields.t +++ /dev/null @@ -1,172 +0,0 @@ -#!./perl -w - -my $w; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print $_[0]; - }; -} - -use strict; -use warnings; -use vars qw($DEBUG); - -package B1; -use fields qw(b1 b2 b3); - -package B2; -use fields '_b1'; -use fields qw(b1 _b2 b2); - -sub new { bless [], shift } - -package D1; -use base 'B1'; -use fields qw(d1 d2 d3); - -package D2; -use base 'B1'; -use fields qw(_d1 _d2); -use fields qw(d1 d2); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package D4; -use base 'D3'; -use fields qw(_d3 d3); - -package M; -sub m {} - -package D5; -use base qw(M B2); - -package Foo::Bar; -use base 'B1'; - -package Foo::Bar::Baz; -use base 'Foo::Bar'; -use fields qw(foo bar baz); - -# Test repeatability for when modules get reloaded. -package B1; -use fields qw(b1 b2 b3); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package main; - -sub fstr { - my $h = shift; - my @tmp; - for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { - my $v = $h->{$k}; - push(@tmp, "$k:$v"); - } - my $str = join(",", @tmp); - print "$h => $str\n" if $DEBUG; - $str; -} - -my %expect = ( - B1 => "b1:1,b2:2,b3:3", - B2 => "_b1:1,b1:2,_b2:3,b2:4", - D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", - D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", - D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", - D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", - D5 => "b1:2,b2:4", - 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', -); - -print "1..", int(keys %expect)+13, "\n"; -my $testno = 0; -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; - print "ok ", ++$testno, "\n"; -} - -# Did we get the appropriate amount of warnings? -print "not " unless $w == 1; -print "ok ", ++$testno, "\n"; - -# A simple object creation and AVHV attribute access test -my B2 $obj1 = D3->new; -$obj1->{b1} = "B2"; -my D3 $obj2 = $obj1; -$obj2->{b1} = "D3"; - -print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; -print "ok ", ++$testno, "\n"; - -# We should get compile time failures field name typos -eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; -print "ok ", ++$testno, "\n"; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -print "not " unless "@$obj1[1,2]" eq "17 29"; -print "ok ", ++$testno, "\n"; -@$obj1[1,2] = (44,28); -print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; -print "ok ", ++$testno, "\n"; - -my $ph = fields::phash(a => 1, b => 2, c => 3); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1, 2, 3]); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1]); -print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; -print "ok ", ++$testno, "\n"; - -eval '$ph = fields::phash("odd")'; -print "not " unless $@ && $@ =~ /^Odd number of/; -print "ok ", ++$testno, "\n"; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { bless [], $_[0]; } - - package main; - my Foo $a = Foo->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - -# check if fields autovivify -{ - package Bar; - use fields qw(foo bar); - sub new { return fields::new($_[0]) } - - package main; - my Bar $a = Bar::->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t deleted file mode 100755 index a97fdd5..0000000 --- a/contrib/perl5/t/lib/filecache.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FileCache; - -# This is really not a complete test as I don't bother to open enough -# files to make real swapping of open filedescriptor happen. - -$path = "foo"; -cacheout $path; - -print $path "\n"; - -close $path; - -print "not " unless -f $path; -print "ok 1\n"; - -unlink $path; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t deleted file mode 100755 index 3072c54..0000000 --- a/contrib/perl5/t/lib/filecopy.t +++ /dev/null @@ -1,109 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -$| = 1; - -my @pass = (0,1); -my $tests = 11; -printf "1..%d\n", $tests * scalar(@pass); - -use File::Copy; - -for my $pass (@pass) { - - require File::Copy; - - my $loopconst = $pass*$tests; - - # First we create a file - open(F, ">file-$$") or die; - binmode F; # for DOSISH platforms, because test 3 copies to stdout - printf F "ok %d\n", 3 + $loopconst; - close F; - - copy "file-$$", "copy-$$"; - - open(F, "copy-$$") or die; - $foo = <F>; - close(F); - - print "not " if -s "file-$$" != -s "copy-$$"; - printf "ok %d\n", 1 + $loopconst; - - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 2+$loopconst; - - binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode - copy "copy-$$", \*STDOUT; - unlink "copy-$$" or die "unlink: $!"; - - open(F,"file-$$"); - copy(*F, "copy-$$"); - open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 4+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - open(F,"file-$$"); - copy(\*F, "copy-$$"); - close(F) or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 5+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - - require IO::File; - $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 6+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - require FileHandle; - my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 7+$loopconst; - unlink "file-$$" or die "unlink: $!"; - - print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); - print "# target disappeared.\nnot " if not -e "copy-$$"; - printf "ok %d\n", 8+$loopconst; - - move "copy-$$", "file-$$" or print "# move did not succeed.\n"; - print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; - open(R, "file-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 9+$loopconst; - - copy "file-$$", "lib"; - open(R, "lib/file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 10+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - move "file-$$", "lib"; - open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) - and not -e "file-$$";; - printf "ok %d\n", 11+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - # warn sprintf "INC->".$INC{"File/Copy.pm"}; - delete $INC{"File/Copy.pm"}; - -} - - -END { - 1 while unlink "file-$$"; - 1 while unlink "lib/file-$$"; -} diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t deleted file mode 100755 index 362c1eb..0000000 --- a/contrib/perl5/t/lib/filefind.t +++ /dev/null @@ -1,197 +0,0 @@ -####!./perl - - -my %Expect; -my $symlink_exists = eval { symlink("",""); 1 }; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ( $symlink_exists ) { print "1..117\n"; } -else { print "1..61\n"; } - -use File::Find; - -find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); -finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); - - -my $case = 2; -my $FastFileTests_OK = 0; - -END { - unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', - 'fa/fab/fab_ord','fa/fab/faba/faba_ord','fb/fb_ord','fb/fba/fba_ord'; - rmdir 'fa/faa'; - rmdir 'fa/fab/faba'; - rmdir 'fa/fab'; - rmdir 'fa'; - rmdir 'fb/fba'; - rmdir 'fb'; - chdir '..'; - rmdir 'for_find'; -} - -sub Check($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n"; } -} - -sub CheckDie($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n $!\n"; exit 0; } -} - -sub touch { - CheckDie( open(my $T,'>',$_[0]) ); -} - -sub MkDir($$) { - CheckDie( mkdir($_[0],$_[1]) ); -} - -sub wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - Check( $Expect{$_} ); - if ( $FastFileTests_OK ) { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d _ ); - } else { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d $_ ); - } - $File::Find::prune=1 if $_ eq 'faba'; - -} - -sub dn_wanted { - my $n = $File::Find::name; - $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); - print "# '$n' => 1\n"; - my $i = rindex($n,'/'); - my $OK = exists($Expect{$n}); - if ( $OK ) { - $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0; - } - Check($OK); - delete $Expect{$n}; -} - -sub d_wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - my $i = rindex($_,'/'); - my $OK = exists($Expect{$_}); - if ( $OK ) { - $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0; - } - Check($OK); - delete $Expect{$_}; -} - -MkDir( 'for_find',0770 ); -CheckDie(chdir(for_find)); -MkDir( 'fa',0770 ); -MkDir( 'fb',0770 ); -touch('fb/fb_ord'); -MkDir( 'fb/fba',0770 ); -touch('fb/fba/fba_ord'); -CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; -touch('fa/fa_ord'); - -MkDir( 'fa/faa',0770 ); -touch('fa/faa/faa_ord'); -MkDir( 'fa/fab',0770 ); -touch('fa/fab/fab_ord'); -MkDir( 'fa/fab/faba',0770 ); -touch('fa/fab/faba/faba_ord'); - -%Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); -delete $Expect{'fsl'} unless $symlink_exists; -%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); -delete @Expect_Dir{'fb','fba'} unless $symlink_exists; -File::Find::find( {wanted => \&wanted, },'fa' ); -Check( scalar(keys %Expect) == 0 ); - -%Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, - 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); -delete $Expect{'fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); -delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; -File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); - -Check( scalar(keys %Expect) == 0 ); - -%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); -delete $Expect{'./fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); -delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; -File::Find::finddepth( {wanted => \&dn_wanted },'.' ); -Check( scalar(keys %Expect) == 0 ); - -%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); -delete $Expect{'./fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); -delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; -File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); -Check( scalar(keys %Expect) == 0 ); - -if ( $symlink_exists ) { - $FastFileTests_OK= 1; - %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, - 'faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); -} - -print "# of cases: $case\n"; diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t deleted file mode 100755 index 9268122..0000000 --- a/contrib/perl5/t/lib/filefunc.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::Spec::Functions; - -if (catfile('a','b','c') eq 'a/b/c') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t deleted file mode 100755 index 0f3e177..0000000 --- a/contrib/perl5/t/lib/filehand.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use FileHandle; -use strict subs; - -autoflush STDOUT 1; - -$mystdout = new_from_fd FileHandle 1,"w"; -$| = 1; -autoflush $mystdout; -print "1..11\n"; - -print $mystdout "ok ".fileno($mystdout)."\n"; - -$fh = (new FileHandle "./TEST", O_RDONLY - or new FileHandle "TEST", O_RDONLY) - and print "ok 2\n"; - - -$buffer = <$fh>; -print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; - - -ungetc $fh ord 'A'; -CORE::read($fh, $buf,1); -print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; - -close $fh; - -$fh = new FileHandle; - -print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer); -print "ok 5\n"; - -$fh->seek(0,0); -print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer); -print "ok 6\n"; - -$fh->seek(0,2); -$line = <$fh>; -print "not " if (defined($line) || !$fh->eof); -print "ok 7\n"; - -print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close); -print "ok 8\n"; - -autoflush STDOUT 0; - -print "not " if ($|); -print "ok 9\n"; - -autoflush STDOUT 1; - -print "not " unless ($|); -print "ok 10\n"; - -if ($^O eq 'dos') -{ - printf("ok %d\n",11); - exit(0); -} - -($rd,$wr) = FileHandle::pipe; - -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; -} -else { - if (fork) { - $wr->close; - print $rd->getline; - } - else { - $rd->close; - $wr->printf("ok %d\n",11); - exit(0); - } -} diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t deleted file mode 100755 index 42e0ae9..0000000 --- a/contrib/perl5/t/lib/filepath.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Path; -use strict; - -my $count = 0; -use warnings; - -print "1..4\n"; - -# first check for stupid permissions second for full, so we clean up -# behind ourselves -for my $perm (0111,0777) { - mkpath("foo/bar"); - chmod $perm, "foo", "foo/bar"; - - print "not " unless -d "foo" && -d "foo/bar"; - print "ok ", ++$count, "\n"; - - rmtree("foo"); - print "not " if -e "foo"; - print "ok ", ++$count, "\n"; -} diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t deleted file mode 100755 index c6d155f..0000000 --- a/contrib/perl5/t/lib/filespec.t +++ /dev/null @@ -1,379 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Each element in this array is a single test. Storing them this way makes -# maintenance easy, and should be OK since perl should be pretty functional -# before these tests are run. - -@tests = ( -# Function Expected -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->splitpath('file')", ',,file' ], -[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], -[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], -[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], -[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], -[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], -[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], -[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], -[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], - -[ "Unix->catpath('','','file')", 'file' ], -[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], -[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], -[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], -[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], -[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], -[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], -[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], -[ "Unix->catpath('','/././d1/','')", '/././d1/' ], -[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], -[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], - -[ "Unix->splitdir('')", '' ], -[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], -[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], -[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], -[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], - -[ "Unix->catdir()", '' ], -[ "Unix->catdir('/')", '/' ], -[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], -[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], - -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->canonpath('')", '' ], -[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], -[ "Unix->canonpath('/.')", '/.' ], - -[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ], -[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], - -[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], -[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], -[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], -[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], -[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], -[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], - -[ "Win32->splitpath('file')", ',,file' ], -[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], -[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], -[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], -[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], -[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], -[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], -[ "Win32->splitpath('file',1)", ',file,' ], -[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], - -[ "Win32->catpath('','','file')", 'file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], -[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], -[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], -[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], -[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], -[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], -[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], -[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], -[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], -[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], -[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], - -[ "Win32->splitdir('')", '' ], -[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], -[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], -[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], -[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], - -[ "Win32->catdir()", '' ], -[ "Win32->catdir('')", '\\' ], -[ "Win32->catdir('/')", '\\' ], -[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], -[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], -[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], -[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], -#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], -[ "Win32->catdir('A:/')", 'A:\\' ], - -[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], - -[ "Win32->canonpath('')", '' ], -[ "Win32->canonpath('a:')", 'A:' ], -[ "Win32->canonpath('A:f')", 'A:f' ], -[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], -[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('////')", '\\\\\\' ], -[ "Win32->canonpath('//')", '\\' ], -[ "Win32->canonpath('/.')", '\\.' ], -[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ], -[ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ], - -[ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], -#[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ], -[ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ], -[ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ], - -[ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ], -[ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('../','C:/')", 'C:\\..' ], -[ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ], -[ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ], -[ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], - -[ "VMS->splitpath('file')", ',,file' ], -[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], -[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], -[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], -[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], - -[ "VMS->catpath('','','file')", 'file' ], -[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], -[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], -[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], -[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], - -[ "VMS->canonpath('')", '' ], -[ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], -[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], -[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], - -[ "VMS->splitdir('')", '' ], -[ "VMS->splitdir('[]')", '' ], -[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], -[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], -[ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ], -[ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ], -[ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], -[ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], - -[ "VMS->catdir('')", '' ], -[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], -[ "VMS->catdir('','-','','d3')", '[-.d3]' ], -[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], -[ "VMS->catdir('[.name]')", '[.name]' ], -[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], - -[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], -[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], -[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], -[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], -[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], -[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], - -[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], -[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], -[ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], -[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], -[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], -[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], - -[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], -[ "OS2->catfile('a','b','c')", 'a/b/c' ], - -[ "Mac->splitpath('file')", ',,file' ], -[ "Mac->splitpath(':file')", ',:,file' ], -[ "Mac->splitpath(':d1',1)", ',:d1:,' ], -[ "Mac->splitpath('d1',1)", 'd1:,,' ], -[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], - -[ "Mac->catdir('')", ':' ], -[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], -[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], -[ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], -[ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], -[ "Mac->catdir('','','','d3')", ':::d3:' ], -[ "Mac->catdir(':name')", ':name:' ], -[ "Mac->catdir(':name',':name')", ':name:name:' ], - -[ "Mac->catfile('a','b','c')", 'a:b:c' ], - -[ "Mac->canonpath('')", '' ], -[ "Mac->canonpath(':')", ':' ], -[ "Mac->canonpath('::')", '::' ], -[ "Mac->canonpath('a::')", 'a::' ], -[ "Mac->canonpath(':a::')", ':a::' ], - -[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], -[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], -[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], -[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], -[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], -[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], -[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], - -[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], -[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], -[ "Mac->rel2abs('','t1:t2:t3')", '' ], -[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], -[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], -[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], -) ; - -# Grab all of the plain routines from File::Spec -use File::Spec @File::Spec::EXPORT_OK ; - -require File::Spec::Unix ; -require File::Spec::Win32 ; - -eval { - require VMS::Filespec ; -} ; - -my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; - -if ( $@ ) { - # Not pretty, but it allows testing of things not implemented soley - # on VMS. It might be better to change File::Spec::VMS to do this, - # making it more usable when running on (say) Unix but working with - # VMS paths. - eval qq- - sub File::Spec::VMS::vmsify { die "$skip_exception" } - sub File::Spec::VMS::unixify { die "$skip_exception" } - sub File::Spec::VMS::vmspath { die "$skip_exception" } - - ; - $INC{"VMS/Filespec.pm"} = 1 ; -} -require File::Spec::VMS ; - -require File::Spec::OS2 ; -require File::Spec::Mac ; - -print "1..", scalar( @tests ), "\n" ; - -my $current_test= 1 ; - -# Test out the class methods -for ( @tests ) { - tryfunc( @$_ ) ; -} - - - -# -# Tries a named function with the given args and compares the result against -# an expected result. Works with functions that return scalars or arrays. -# -sub tryfunc { - my $function = shift ; - my $expected = shift ; - my $platform = shift ; - - if ($platform && $^O ne $platform) { - print "ok $current_test # skipped: $function\n" ; - ++$current_test ; - return; - } - - $function =~ s#\\#\\\\#g ; - - my $got ; - if ( $function =~ /^[^\$].*->/ ) { - $got = eval( "join( ',', File::Spec::$function )" ) ; - } - else { - $got = eval( "join( ',', $function )" ) ; - } - - if ( $@ ) { - if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) { - chomp $@ ; - print "ok $current_test # skip $function: $@\n" ; - } - else { - chomp $@ ; - print "not ok $current_test # $function: $@\n" ; - } - } - elsif ( !defined( $got ) || $got ne $expected ) { - print "not ok $current_test # $function: got '$got', expected '$expected'\n" ; - } - else { - print "ok $current_test # $function\n" ; - } - ++$current_test ; -} diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t deleted file mode 100755 index 3e742f9..0000000 --- a/contrib/perl5/t/lib/findbin.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FindBin qw($Bin); - -print "not " unless $Bin =~ m,t[/.]lib\]?$,; -print "ok 1\n"; diff --git a/contrib/perl5/t/lib/ftmp-mktemp.t b/contrib/perl5/t/lib/ftmp-mktemp.t deleted file mode 100755 index b0a7872..0000000 --- a/contrib/perl5/t/lib/ftmp-mktemp.t +++ /dev/null @@ -1,114 +0,0 @@ -#!/usr/bin/perl -w - -# Test for mktemp family of commands in File::Temp -# Use STANDARD safe level for these tests - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 9); -} - -use strict; - -use File::Spec; -use File::Path; -use File::Temp qw/ :mktemp unlink0 /; - -ok(1); - -# MKSTEMP - test - -# Create file in temp directory -my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX'); - -(my $fh, $template) = mkstemp($template); - -print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $template) ); - -# Autoflush -$fh->autoflush(1) if $] >= 5.006; - -# Try printing something to the file -my $string = "woohoo\n"; -print $fh $string; - -# rewind the file -ok(seek( $fh, 0, 0)); - -# Read from the file -my $line = <$fh>; - -# compare with previous string -ok($string, $line); - -# Tidy up -# This test fails on Windows NT since it seems that the size returned by -# stat(filehandle) does not always equal the size of the stat(filename) -# This must be due to caching. In particular this test writes 7 bytes -# to the file which are not recognised by stat(filename) -# Simply waiting 3 seconds seems to be enough for the system to update - -if ($^O eq 'MSWin32') { - sleep 3; -} -my $status = unlink0($fh, $template); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# MKSTEMPS -# File with suffix. This is created in the current directory so -# may be problematic on NFS - -$template = "suffixXXXXXX"; -my $suffix = ".dat"; - -($fh, my $fname) = mkstemps($template, $suffix); - -print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $fname) ); - -# This fails if you are running on NFS -# If this test fails simply skip it rather than doing a hard failure -$status = unlink0($fh, $fname); - -if ($status) { - ok($status); -} else { - skip("Skip test failed probably due to cwd being on NFS",1) -} - -# MKDTEMP -# Temp directory - -$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX'); - -my $tmpdir = mkdtemp($template); - -print "# MKDTEMP: Name is $tmpdir from template $template\n"; - -ok( (-d $tmpdir ) ); - -# Need to tidy up after myself -rmtree($tmpdir); - -# MKTEMP -# Just a filename, not opened - -$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX'); - -my $tmpfile = mktemp($template); - -print "# MKTEMP: Tempfile is $template -> $tmpfile\n"; - -# Okay if template no longer has XXXXX in - - -ok( ($tmpfile !~ /XXXXX$/) ); diff --git a/contrib/perl5/t/lib/ftmp-posix.t b/contrib/perl5/t/lib/ftmp-posix.t deleted file mode 100755 index 79496d8..0000000 --- a/contrib/perl5/t/lib/ftmp-posix.t +++ /dev/null @@ -1,81 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - POSIX functions - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 7); -} - -use strict; - -use File::Temp qw/ :POSIX unlink0 /; -ok(1); - -# TMPNAM - scalar - -print "# TMPNAM: in a scalar context: \n"; -my $tmpnam = tmpnam(); - -# simply check that the file does not exist -# Not a 100% water tight test though if another program -# has managed to create one in the meantime. -ok( !(-e $tmpnam )); - -print "# TMPNAM file name: $tmpnam\n"; - -# TMPNAM list context -# Not strict posix behaviour -(my $fh, $tmpnam) = tmpnam(); - -print "# TMPNAM: in list context: $fh $tmpnam\n"; - -# File is opened - make sure it exists -ok( (-e $tmpnam )); - -# Unlink it - a possible NFS issue again if TMPDIR is not a local disk -my $status = unlink0($fh, $tmpnam); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# TMPFILE - -$fh = tmpfile(); - -if (defined $fh) { - ok( $fh ); - print "# TMPFILE: tmpfile got FH $fh\n"; - - $fh->autoflush(1) if $] >= 5.006; - - # print something to it - my $original = "Hello a test\n"; - print "# TMPFILE: Wrote line: $original"; - print $fh $original - or die "Error printing to tempfile\n"; - - # rewind it - ok( seek($fh,0,0) ); - - # Read from it - my $line = <$fh>; - - print "# TMPFILE: Read line: $line"; - ok( $original, $line); - - close($fh); - -} else { - # Skip all the remaining tests - foreach (1..3) { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); - } -} - - - - diff --git a/contrib/perl5/t/lib/ftmp-security.t b/contrib/perl5/t/lib/ftmp-security.t deleted file mode 100755 index 96b2c42..0000000 --- a/contrib/perl5/t/lib/ftmp-security.t +++ /dev/null @@ -1,140 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - Security levels - -# Some of the security checking will not work on all platforms -# Test a simple open in the cwd and tmpdir foreach of the -# security levels - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 13); -} - -use strict; -use File::Spec; - -# Set up END block - this needs to happen before we load -# File::Temp since this END block must be evaluated after the -# END block configured by File::Temp -my @files; # list of files to remove -END { foreach (@files) { ok( !(-e $_) )} } - -use File::Temp qw/ tempfile unlink0 /; -ok(1); - -# The high security tests must currently be skipped on some platforms -my $skipplat = ( ( - # No sticky bits. - $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'dos' - ) ? 1 : 0 ); - -# Can not run high security tests in perls before 5.6.0 -my $skipperl = ($] < 5.006 ? 1 : 0 ); - -# Determine whether we need to skip things and why -my $skip = 0; -if ($skipplat) { - $skip = "Skip Not supported on this platform"; -} elsif ($skipperl) { - $skip = "Skip Perl version must be v5.6.0 for these tests"; - -} - -print "# We will be skipping some tests : $skip\n" if $skip; - -# start off with basic checking - -File::Temp->safe_level( File::Temp::STANDARD ); - -print "# Testing with STANDARD security...\n"; - -&test_security(0); - -# Try medium - -File::Temp->safe_level( File::Temp::MEDIUM ) - unless $skip; - -print "# Testing with MEDIUM security...\n"; - -# Now we need to start skipping tests -&test_security($skip); - -# Try HIGH - -File::Temp->safe_level( File::Temp::HIGH ) - unless $skip; - -print "# Testing with HIGH security...\n"; - -&test_security($skip); - -exit; - -# Subroutine to open two temporary files. -# one is opened in the current dir and the other in the temp dir - -sub test_security { - - # Read in the skip flag - my $skip = shift; - - # If we are skipping we need to simply fake the correct number - # of tests -- we dont use skip since the tempfile() commands will - # fail with MEDIUM/HIGH security before the skip() command would be run - if ($skip) { - - skip($skip,1); - skip($skip,1); - - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - - return; - } - - # Create the tempfile - my $template = "tmpXXXXX"; - my ($fh1, $fname1) = eval { tempfile ( $template, - DIR => File::Spec->tmpdir, - UNLINK => 1, - ); - }; - - if (defined $fname1) { - print "# fname1 = $fname1\n"; - ok( (-e $fname1) ); - push(@files, $fname1); # store for end block - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - - # Explicitly - if ( $< < File::Temp->top_system_uid() ){ - skip("Skip Test inappropriate for root", 1); - eval q{ END { skip($skip,1); } 1; } || die; - return; - } - my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; - if (defined $fname2) { - print "# fname2 = $fname2\n"; - ok( (-e $fname2) ); - push(@files, $fname2); # store for end block - close($fh2); - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - -} diff --git a/contrib/perl5/t/lib/ftmp-tempfile.t b/contrib/perl5/t/lib/ftmp-tempfile.t deleted file mode 100755 index ed59765..0000000 --- a/contrib/perl5/t/lib/ftmp-tempfile.t +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - tempfile function - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 20); -} - -use strict; -use File::Spec; - -# Will need to check that all files were unlinked correctly -# Set up an END block here to do it - -# Arrays containing list of dirs/files to test -my (@files, @dirs, @still_there); - -# And a test for files that should still be around -# These are tidied up -END { - foreach (@still_there) { - ok( -f $_ ); - ok( unlink( $_ ) ); - ok( !(-f $_) ); - } -} - -# Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_) )} } - -# And a test for directories -END { foreach (@dirs) { ok( !(-d $_) )} } - -# Need to make sure that the END blocks are setup before -# the ones that File::Temp configures since END blocks are evaluated -# in revers order and we need to check the files *after* File::Temp -# removes them -use File::Temp qw/ tempfile tempdir/; - -# Now we start the tests properly -ok(1); - - -# Tempfile -# Open tempfile in some directory, unlink at end -my ($fh, $tempfile) = tempfile( - UNLINK => 1, - SUFFIX => '.txt', - ); - -ok( (-f $tempfile) ); -# Should still be around after closing -ok( close( $fh ) ); -ok( (-f $tempfile) ); -# Check again at exit -push(@files, $tempfile); - -# TEMPDIR test -# Create temp directory in current dir -my $template = 'tmpdirXXXXXX'; -print "# Template: $template\n"; -my $tempdir = tempdir( $template , - DIR => File::Spec->curdir, - CLEANUP => 1, - ); - -print "# TEMPDIR: $tempdir\n"; - -ok( (-d $tempdir) ); -push(@dirs, $tempdir); - -# Create file in the temp dir -($fh, $tempfile) = tempfile( - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile)); -push(@files, $tempfile); - -# Test tempfile -# ..and again -($fh, $tempfile) = tempfile( - DIR => $tempdir, - ); - - -ok( (-f $tempfile )); -push(@files, $tempfile); - -print "# TEMPFILE: Created $tempfile\n"; - -# and another (with template) - -($fh, $tempfile) = tempfile( 'helloXXXXXXX', - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile) ); -push(@files, $tempfile); - - -# Create a temporary file that should stay around after -# it has been closed -($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 ); -print "# TEMPFILE: Created $tempfile\n"; -ok( -f $tempfile ); -ok( close( $fh ) ); -push( @still_there, $tempfile); # check at END - -# Would like to create a temp file and just retrieve the handle -# but the test is problematic since: -# - We dont know the filename so we cant check that it is tidied -# correctly -# - The unlink0 required on unix for tempfile creation will fail -# on NFS -# Try to do what we can. -# Tempfile croaks on error so we need an eval -$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; - -if ($fh) { - - # print something to it to make sure something is there - ok( print $fh "Test\n" ); - - # Close it - can not check it is gone since we dont know the name - ok( close($fh) ); - -} else { - skip "Skip Failed probably due to NFS", 1; - skip "Skip Failed probably due to NFS", 1; -} - -# Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; - diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t deleted file mode 100755 index ecbd662..0000000 --- a/contrib/perl5/t/lib/gdbm.t +++ /dev/null @@ -1,426 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bGDBM_File\b/) { - print "1..0 # Skip: GDBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - - -use GDBM_File; - -print "1..68\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h ; -print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use GDBM_File; - @ISA=qw(GDBM_File); - @EXPORT = @GDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - unlink <dbhash.tmp*> ; - - eval 'use SubDB ; '; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; - main::ok(17, $@ eq "" ) ; - main::ok(18, $ret == 1) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(19, $@ eq "") ; - main::ok(20, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - 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 ; - use warnings ; - 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, ! defined $result{"fetch value"} ); - 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 ; - use warnings ; - 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*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use GDBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); - $h{ABC} = undef; - ok(68, $a eq "") ; - untie %h; - unlink <Op.dbmx*>; -} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t deleted file mode 100755 index fb70f10..0000000 --- a/contrib/perl5/t/lib/getopt.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..11\n"; - -use Getopt::Std; - -# First we test the getopt function -@ARGV = qw(-xo -f foo -y file); -getopt('f'); - -print "not " if "@ARGV" ne 'file'; -print "ok 1\n"; - -print "not " unless $opt_x && $opt_o && opt_y; -print "ok 2\n"; - -print "not " unless $opt_f eq 'foo'; -print "ok 3\n"; - - -# Then we try the getopts -$opt_o = $opt_i = $opt_f = undef; -@ARGV = qw(-foi -i file); -getopts('oif:') or print "not "; -print "ok 4\n"; - -print "not " unless "@ARGV" eq 'file'; -print "ok 5\n"; - -print "not " unless $opt_i and $opt_f eq 'oi'; -print "ok 6\n"; - -print "not " if $opt_o; -print "ok 7\n"; - -# Try illegal options, but avoid printing of the error message - -open(STDERR, ">stderr") || die; - -@ARGV = qw(-h help); - -!getopts("xf:y") or print "not "; -print "ok 8\n"; - - -# Then try the Getopt::Long module - -use Getopt::Long; - -@ARGV = qw(--help --file foo --foo --nobar --num=5 -- file); - -GetOptions( - 'help' => \$HELP, - 'file:s' => \$FILE, - 'foo!' => \$FOO, - 'bar!' => \$BAR, - 'num:i' => \$NO, -) || print "not "; -print "ok 9\n"; - -print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5; -print "ok 10\n"; - -print "not " unless "@ARGV" eq "file"; -print "ok 11\n"; - -close STDERR; -unlink "stderr"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t deleted file mode 100755 index a014bfd..0000000 --- a/contrib/perl5/t/lib/glob-basic.t +++ /dev/null @@ -1,129 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..9\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob ':glob'; -use Cwd (); -$loaded = 1; -print "ok 1\n"; - -sub array { - return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; -} - -# look for the contents of the current directory -$ENV{PATH} = "/bin"; -delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; -@correct = (); -if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { - @correct = grep { !/^\./ } sort readdir(D); - closedir D; -} -@a = File::Glob::glob("*", 0); -@a = sort @a; -if ("@a" ne "@correct" || GLOB_ERROR) { - print "# |@a| ne |@correct|\nnot "; -} -print "ok 2\n"; - -# look up the user's home directory -# should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' && $^O ne 'VMS') { - eval { - ($name, $home) = (getpwuid($>))[0,7]; - 1; - } and do { - @a = bsd_glob("~$name", GLOB_TILDE); - if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { - print "not "; - } - }; -} -print "ok 3\n"; - -# check backslashing -# should return a list with one item, and not set ERROR -@a = bsd_glob('TEST', GLOB_QUOTE); -if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { - local $/ = "]["; - print "# [@a]\n"; - print "not "; -} -print "ok 4\n"; - -# check nonexistent checks -# should return an empty list -# XXX since errfunc is NULL on win32, this test is not valid there -@a = bsd_glob("asdfasdf", 0); -if ($^O ne 'MSWin32' and scalar @a != 0) { - print "# |@a|\nnot "; -} -print "ok 5\n"; - -# check bad protections -# should return an empty list, and set ERROR -if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' - or $^O eq 'cygwin' or Cwd::cwd() =~ m#^/afs#s or not $>) -{ - print "ok 6 # skipped\n"; -} -else { - $dir = "PtEeRsLt.dir"; - mkdir $dir, 0; - @a = bsd_glob("$dir/*", GLOB_ERR); - #print "\@a = ", array(@a); - rmdir $dir; - if (scalar(@a) != 0 || GLOB_ERROR == 0) { - print "not "; - } - print "ok 6\n"; -} - -# check for csh style globbing -@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); -unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { - print "not "; -} -print "ok 7\n"; - -@a = bsd_glob( - '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) -); - -# Working on t/TEST often causes this test to fail because it sees temp -# and RCS files. Filter them out, and .pm files too. -@a = grep !/(,v$|~$|\.pm$)/, @a; - -unless (@a == 3 - and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') - and $a[1] eq 'a' - and $a[2] eq 'b') -{ - print "not "; -} -print "ok 8\n"; - -# "~" should expand to $ENV{HOME} -$ENV{HOME} = "sweet home"; -@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { - print "not "; -} -print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t deleted file mode 100755 index 881470c..0000000 --- a/contrib/perl5/t/lib/glob-case.t +++ /dev/null @@ -1,60 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..7\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob qw(:glob csh_glob); -$loaded = 1; -print "ok 1\n"; - -my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; - -# Test the actual use of the case sensitivity tags, via csh_glob() -import File::Glob ':nocase'; -@a = csh_glob($pat); # At least glob-basic.t glob-case.t glob-global.t -print "not " unless @a >= 3; -print "ok 2\n"; - -# This may fail on systems which are not case-PRESERVING -import File::Glob ':case'; -@a = csh_glob($pat); # None should be uppercase -print "not " unless @a == 0; -print "ok 3\n"; - -# Test the explicit use of the GLOB_NOCASE flag -@a = bsd_glob($pat, GLOB_NOCASE); -print "not " unless @a >= 3; -print "ok 4\n"; - -# Test Win32 backslash nastiness... -if ($^O ne 'MSWin32') { - print "ok 5\nok 6\nok 7\n"; -} -else { - @a = File::Glob::glob("lib\\g*.t"); - print "not " unless @a >= 3; - print "ok 5\n"; - mkdir "[]", 0; - @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); - rmdir "[]"; - print "# returned @a\nnot " unless @a == 1; - print "ok 6\n"; - @a = bsd_glob("lib\\*", GLOB_QUOTE); - print "not " if @a == 0; - print "ok 7\n"; -} diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t deleted file mode 100755 index 1d79032..0000000 --- a/contrib/perl5/t/lib/glob-global.t +++ /dev/null @@ -1,152 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..10\n"; -} -END { - print "not ok 1\n" unless $loaded; -} - -BEGIN { - *CORE::GLOBAL::glob = sub { "Just another Perl hacker," }; -} - -BEGIN { - if ("Just another Perl hacker," ne (<*>)[0]) { - die <<EOMessage; -Your version of perl ($]) doesn't seem to allow extensions to override -the core glob operator. -EOMessage - } -} - -use File::Glob ':globally'; -$loaded = 1; -print "ok 1\n"; - -$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; -my @r = glob; -print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); -print "ok 2\n"; - -# we should have at least basic.t, global.t, taint.t -print "# |@r|\nnot " if @r < 3; -print "ok 3\n"; - -# check if <*/*> works -if ($^O eq "MacOS") { - @r = <:*:*.t>; -} else { - @r = <*/*.t>; -} -# at least t/global.t t/basic.t, t/taint.t -print "not " if @r < 3; -print "ok 4\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -if ($^O eq "MacOS") { - while (defined($_ = <:*:*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 5\n"; - -# check if list context works -@r = (); -if ($^O eq "MacOS") { - for (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if implicit assign to $_ in while() works -@r = (); -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 7\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# how about in a different package, like? -package Foo; -use File::Glob ':globally'; -@s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# test if different glob ops maintain independent contexts -@s = (); -my $i = 0; -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_ <"; - push @s, $_; - while (<:bas*:*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} else { - while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} -print "not " if "@r" ne "@s" or not $i; -print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t deleted file mode 100755 index 4c09903..0000000 --- a/contrib/perl5/t/lib/glob-taint.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..2\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob; -$loaded = 1; -print "ok 1\n"; - -# all filenames should be tainted -@a = File::Glob::bsd_glob("*"); -eval { $a = join("",@a), kill 0; 1 }; -unless ($@ =~ /Insecure dependency/) { - print "not "; -} -print "ok 2\n"; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t deleted file mode 100755 index c5d857d..0000000 --- a/contrib/perl5/t/lib/gol-basic.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long qw(:config no_ignore_case); -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if GetOptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t deleted file mode 100755 index 0bbe386..0000000 --- a/contrib/perl5/t/lib/gol-compat.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -require "newgetopt.pl"; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -$newgetopt::ignorecase = 0; -$newgetopt::ignorecase = 0; -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if NGetOpt ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t deleted file mode 100755 index 3bd81a3..0000000 --- a/contrib/perl5/t/lib/gol-linkage.t +++ /dev/null @@ -1,37 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; - -print "1..18\n"; - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); -%lnk = (); -print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s"); -print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n"); -print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n"); - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("default","no_ignore_case"); -%lnk = (); -my $foo; -print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s"); -print ((defined $foo) ? "" : "not ", "ok 10\n"); -print (($foo == 1) ? "" : "not ", "ok 11\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 14\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); -print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); -print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); diff --git a/contrib/perl5/t/lib/gol-oo.t b/contrib/perl5/t/lib/gol-oo.t deleted file mode 100755 index 98f3eaa..0000000 --- a/contrib/perl5/t/lib/gol-oo.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -my $p = new Getopt::Long::Parser (config => ["no_ignore_case"]); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if $p->getoptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/h2ph.h b/contrib/perl5/t/lib/h2ph.h deleted file mode 100644 index cddf0a7..0000000 --- a/contrib/perl5/t/lib/h2ph.h +++ /dev/null @@ -1,85 +0,0 @@ -/* - * Test header file for h2ph - * - * Try to test as many constructs as possible - * For example, the multi-line comment :) - */ - -/* And here's a single line comment :) */ - -/* Test #define with no indenting, over multiple lines */ -#define SQUARE(x) \ -((x)*(x)) - -/* Test #ifndef and parameter interpretation*/ -#ifndef ERROR -#define ERROR(x) fprintf(stderr, "%s\n", x[2][3][0]) -#endif /* ERROR */ - -#ifndef _H2PH_H_ -#define _H2PH_H_ - -/* #ident - doesn't really do anything, but I think it always gets included anyway */ -#ident "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" - -/* Test #undef */ -#undef MAX -#define MAX(a,b) ((a) > (b) ? (a) : (b)) - -/* Test #ifdef */ -#ifdef __SOME_UNIMPORTANT_PROPERTY -#define MIN(a,b) ((a) < (b) ? (a) : (b)) -#endif /* __SOME_UNIMPORTANT_PROPERTY */ - -/* - * Test #if, #elif, #else, #endif, #warn and #error, and `!' - * Also test whitespace between the `#' and the command - */ -#if !(defined __SOMETHING_MORE_IMPORTANT) -# warn Be careful... -#elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT) -# error Nup, can't go on /* ' /* stupid font-lock-mode */ -#else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */ -# define EVERYTHING_IS_OK -#endif - -/* Test && and || */ -#undef WHATEVER -#if (!((defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO)) \ - || defined __SOMETHING_OVERPOWERING) -# define WHATEVER 6 -#elif !(defined __SOMETHING_TRIVIAL) /* defined __SOMETHING_LESS_SO */ -# define WHATEVER 7 -#elif !(defined __SOMETHING_LESS_SO) /* defined __SOMETHING_TRIVIAL */ -# define WHATEVER 8 -#else /* defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO */ -# define WHATEVER 1000 -#endif - -/* - * Test #include, #import and #include_next - * #include_next is difficult to test, it really depends on the actual - * circumstances - for example, `#include_next <limits.h>' on a Linux system - * with `use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever - * your equivalent is... - */ -#include <sys/socket.h> -#import "sys/ioctl.h" -#include_next <sys/fcntl.h> - -/* typedefs should be ignored */ -typedef struct a_struct { - int typedefs_should; - char be_ignored; - long as_well; -} a_typedef; - -/* - * however, typedefs of enums and just plain enums should end up being treated - * like a bunch of #defines... - */ - -typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon, - Tue, Wed, Thu, Fri, Sat } days_of_week; - -#endif /* _H2PH_H_ */ diff --git a/contrib/perl5/t/lib/h2ph.pht b/contrib/perl5/t/lib/h2ph.pht deleted file mode 100644 index e5b2932..0000000 --- a/contrib/perl5/t/lib/h2ph.pht +++ /dev/null @@ -1,71 +0,0 @@ -require '_h2ph_pre.ph'; - -unless(defined(&SQUARE)) { - sub SQUARE { - local($x) = @_; - eval q((($x)*($x))); - } -} -unless(defined(&ERROR)) { - eval 'sub ERROR { - local($x) = @_; - eval q( &fprintf( &stderr, \\"%s\\\\n\\", $x->[2][3][0])); - }' unless defined(&ERROR); -} -unless(defined(&_H2PH_H_)) { - eval 'sub _H2PH_H_ () {1;}' unless defined(&_H2PH_H_); - # "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" - undef(&MAX) if defined(&MAX); - eval 'sub MAX { - local($a,$b) = @_; - eval q((($a) > ($b) ? ($a) : ($b))); - }' unless defined(&MAX); - if(defined(&__SOME_UNIMPORTANT_PROPERTY)) { - eval 'sub MIN { - local($a,$b) = @_; - eval q((($a) < ($b) ? ($a) : ($b))); - }' unless defined(&MIN); - } - 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\ "); - } else { - eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); - } - undef(&WHATEVER) if defined(&WHATEVER); - if((!((defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0) && defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0))) || defined (defined(&__SOMETHING_OVERPOWERING) ? &__SOMETHING_OVERPOWERING : 0))) { - eval 'sub WHATEVER () {6;}' unless defined(&WHATEVER); - } - elsif(!(defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0)) ) { - eval 'sub WHATEVER () {7;}' unless defined(&WHATEVER); - } - elsif(!(defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0)) ) { - eval 'sub WHATEVER () {8;}' unless defined(&WHATEVER); - } else { - eval 'sub WHATEVER () {1000;}' unless defined(&WHATEVER); - } - require 'sys/socket.ph'; - require 'sys/ioctl.ph'; - eval { - my(%INCD) = map { $INC{$_} => 1 } (grep { $_ eq "sys/fcntl.ph" } keys(%INC)); - my(@REM) = map { "$_/sys/fcntl.ph" } (grep { not exists($INCD{"$_/sys/fcntl.ph"})and -f "$_/sys/fcntl.ph" } @INC); - require "$REM[0]" if @REM; - }; - warn($@) if $@; - eval("sub sun () { 0; }") unless defined(&sun); - eval("sub mon () { 1; }") unless defined(&mon); - eval("sub tue () { 2; }") unless defined(&tue); - eval("sub wed () { 3; }") unless defined(&wed); - eval("sub thu () { 4; }") unless defined(&thu); - eval("sub fri () { 5; }") unless defined(&fri); - eval("sub sat () { 6; }") unless defined(&sat); - eval("sub Sun () { 0; }") unless defined(&Sun); - eval("sub Mon () { 1; }") unless defined(&Mon); - eval("sub Tue () { 2; }") unless defined(&Tue); - eval("sub Wed () { 3; }") unless defined(&Wed); - eval("sub Thu () { 4; }") unless defined(&Thu); - eval("sub Fri () { 5; }") unless defined(&Fri); - eval("sub Sat () { 6; }") unless defined(&Sat); -} -1; diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t deleted file mode 100755 index 15dc2b5..0000000 --- a/contrib/perl5/t/lib/h2ph.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -# quickie tests to see if h2ph actually runs and does more or less what is -# expected - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..2\n"; - -# quickly compare two text files -sub txt_compare { - local ($/, $A, $B); - for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ } - $A cmp $B; -} - -unless(-e '../utils/h2ph') { - print("ok 1\nok 2\n"); - # i'll probably get in trouble for this :) -} else { - # does it run? - $ok = system("./perl -I../lib ../utils/h2ph -d. -Q lib/h2ph.h"); - print(($ok == 0 ? "" : "not "), "ok 1\n"); - - # does it work? well, does it do what we expect? :-) - $ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht"); - print(($ok == 0 ? "" : "not "), "ok 2\n"); - - # cleanup - should this be in an END block? - unlink("lib/h2ph.ph"); - unlink("_h2ph_pre.ph"); -} diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t deleted file mode 100755 index 85a04cd..0000000 --- a/contrib/perl5/t/lib/hostname.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { - print "1..0 # Skip: Sys::Hostname was not built\n"; - exit 0; - } -} - -use Sys::Hostname; - -eval { - $host = hostname; -}; - -if ($@) { - print "1..0\n" if $@ =~ /Cannot get host name/; -} else { - print "1..1\n"; - print "# \$host = `$host'\n"; - print "ok 1\n"; -} diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t deleted file mode 100755 index db1a322..0000000 --- a/contrib/perl5/t/lib/io_const.t +++ /dev/null @@ -1,33 +0,0 @@ - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -use IO::Handle; - -print "1..6\n"; -my $i = 1; -foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) { - my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0; - my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef; - my $v2 = IO::Handle::constant($_); - my $d2 = defined($v2); - - print "not " - if($d1 != $d2 || ($d1 && ($v1 != $v2))); - print "ok ",$i++,"\n"; -} diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t deleted file mode 100755 index 3689871..0000000 --- a/contrib/perl5/t/lib/io_dir.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } - require Config; import Config; - if ($] < 5.00326 || not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -use IO::Dir qw(DIR_UNLINK); - -print "1..10\n"; - -$dot = new IO::Dir "."; -print defined($dot) ? "ok" : "not ok", " 1\n"; - -@a = sort <*>; -do { $first = $dot->read } while defined($first) && $first =~ /^\./; -print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; - -@b = sort($first, (grep {/^[^.]/} $dot->read)); -print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; - -$dot->rewind; -@c = sort grep {/^[^.]/} $dot->read; -print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; - -$dot->close; -$dot->rewind; -print defined($dot->read) ? "not ok" : "ok", " 5\n"; - -open(FH,'>X') || die "Can't create x"; -print FH "X"; -close(FH); - -tie %dir, IO::Dir, "."; -my @files = keys %dir; - -# I hope we do not have an empty dir :-) -print @files ? "ok" : "not ok", " 6\n"; - -my $stat = $dir{'X'}; -print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1 - ? "ok" : "not ok", " 7\n"; - -delete $dir{'X'}; - -print -f 'X' ? "ok" : "not ok", " 8\n"; - -tie %dirx, IO::Dir, ".", DIR_UNLINK; - -my $statx = $dirx{'X'}; -print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 - ? "ok" : "not ok", " 9\n"; - -delete $dirx{'X'}; - -print -f 'X' ? "not ok" : "ok", " 10\n"; diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t deleted file mode 100755 index 0f17264..0000000 --- a/contrib/perl5/t/lib/io_dup.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../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; -use IO::File; - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..6\n"; - -print "ok 1\n"; - -$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w"); -$duperr = IO::Handle->new->fdopen( \*STDERR ,"w"); - -$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle"; -$stderr = \*STDERR; bless $stderr, "IO::Handle"; - -$stdout->open( "Io.dup","w") || die "Can't open stdout"; -$stderr->fdopen($stdout,"w"); - -print $stdout "ok 2\n"; -print $stderr "ok 3\n"; -if ($^O eq 'MSWin32') { - print `echo ok 4`; - print `echo ok 5 1>&2`; # does this *really* work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} - -$stderr->close; -$stdout->close; - -$stdout->fdopen($dupout,"w"); -$stderr->fdopen($duperr,"w"); - -if ($^O eq 'MSWin32') { print `type Io.dup` } -else { system 'cat Io.dup' } -unlink 'Io.dup'; - -print STDOUT "ok 6\n"; diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t deleted file mode 100755 index cf55c98..0000000 --- a/contrib/perl5/t/lib/io_linenum.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./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 - } - @INC = '../lib'; - require strict; import strict; -} - -use Test; - -BEGIN { plan tests => 12 } - -use IO::File; - -sub lineno -{ - my ($f) = @_; - my $l; - $l .= "$. "; - $l .= $f->input_line_number; - $l .= " $."; # check $. before and after input_line_number - $l; -} - -my $t; - -open (F, $File) or die $!; -my $io = IO::File->new($File) or die $!; - -<F> for (1 .. 10); -ok(lineno($io), "10 0 10"); - -$io->getline for (1 .. 5); -ok(lineno($io), "5 5 5"); - -<F>; -ok(lineno($io), "11 5 11"); - -$io->getline; -ok(lineno($io), "6 6 6"); - -$t = tell F; # tell F; provokes a warning -ok(lineno($io), "11 6 11"); - -<F>; -ok(lineno($io), "12 6 12"); - -select F; -ok(lineno($io), "12 6 12"); - -<F> for (1 .. 10); -ok(lineno($io), "22 6 22"); - -$io->getline for (1 .. 5); -ok(lineno($io), "11 11 11"); - -$t = tell F; -# We used to have problems here before local $. worked. -# input_line_number() used to use select and tell. When we did the -# same, that mechanism broke. It should work now. -ok(lineno($io), "22 11 22"); - -{ - local $.; - $io->getline for (1 .. 5); - ok(lineno($io), "16 16 16"); -} - -ok(lineno($io), "22 16 22"); diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t deleted file mode 100755 index 55030b5..0000000 --- a/contrib/perl5/t/lib/io_multihomed.t +++ /dev/null @@ -1,124 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; - -print "1..8\n"; - - -package Multi; -require IO::Socket::INET; -@ISA=qw(IO::Socket::INET); - -use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in); - -sub _get_addr -{ - my($sock,$addr_str, $multi) = @_; - #print "_get_addr($sock, $addr_str, $multi)\n"; - - print "not " unless $multi; - print "ok 2\n"; - - ( - # private IP-addresses which I hope does not work anywhere :-) - inet_aton("10.250.230.10"), - inet_aton("10.250.230.12"), - inet_aton("127.0.0.1") # loopback - ) -} - -sub connect -{ - my $self = shift; - if (@_ == 1) { - my($port, $addr) = unpack_sockaddr_in($_[0]); - $addr = inet_ntoa($addr); - #print "connect($self, $port, $addr)\n"; - if($addr eq "10.250.230.10") { - print "ok 3\n"; - return 0; - } - if($addr eq "10.250.230.12") { - print "ok 4\n"; - return 0; - } - } - $self->SUPER::connect(@_); -} - - - -package main; - -use IO::Socket; - -$listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - Timeout => 5, - ) or die "$!"; - -print "ok 1\n"; - -$port = $listen->sockport; - -if($pid = fork()) { - - $sock = $listen->accept() or die "$!"; - print "ok 5\n"; - - print $sock->getline(); - print $sock "ok 7\n"; - - waitpid($pid,0); - - $sock->close; - - print "ok 8\n"; - -} elsif(defined $pid) { - - $sock = Multi->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost', - MultiHomed => 1, - Timeout => 1, - ) or die "$!"; - - print $sock "ok 6\n"; - sleep(1); # race condition - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t deleted file mode 100755 index ae18224..0000000 --- a/contrib/perl5/t/lib/io_pipe.t +++ /dev/null @@ -1,123 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - 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; - } - } -} - -use IO::Pipe; - -my $perl = './perl'; - -$| = 1; -print "1..10\n"; - -$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); -while (<$pipe>) { - s/^not //; - print; -} -$pipe->close or print "# \$!=$!\nnot "; -print "ok 2\n"; - -$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; -$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); -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(); - -if($pid) - { - $pipe->writer; - print $pipe "Xk 5\n"; - print $pipe "oY 6\n"; - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->reader; - $stdin = bless \*STDIN, "IO::Handle"; - $stdin->fdopen($pipe,"r"); - exec 'tr', 'YX', 'ko'; - } -else - { - die "# error = $!"; - } - -$pipe = new IO::Pipe; -$pid = fork(); - -if($pid) - { - $pipe->reader; - while(<$pipe>) { - s/^not //; - print; - } - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->writer; - - $stdout = bless \*STDOUT, "IO::Handle"; - $stdout->fdopen($pipe,"w"); - print STDOUT "not ok 7\n"; - exec 'echo', 'not ok 8'; - } -else - { - die; - } - -$pipe = new IO::Pipe; -$pipe->writer; - -$SIG{'PIPE'} = 'broken_pipe'; - -sub broken_pipe { - print "ok 9\n"; -} - -print $pipe "not ok 9\n"; -$pipe->close; - -sleep 1; - -print "ok 10\n"; - diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t deleted file mode 100755 index d391566..0000000 --- a/contrib/perl5/t/lib/io_poll.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -if ($^O eq 'mpeix') { - print "1..0 # Skip: broken on MPE/iX\n"; - exit 0; -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..9\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"; - -$poll->remove($dupout); -print "not " - if $poll->handles; -print "ok 9\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t deleted file mode 100755 index 5d1dce3..0000000 --- a/contrib/perl5/t/lib/io_sel.t +++ /dev/null @@ -1,132 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..23\n"; - -use IO::Select 1.09; - -my $sel = new IO::Select(\*STDIN); -$sel->add(4, 5) == 2 or print "not "; -print "ok 1\n"; - -$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; -print "ok 2\n"; - -@handles = $sel->handles; -print "not " unless $sel->count == 4 && @handles == 4; -print "ok 3\n"; -#print $sel->as_string, "\n"; - -$sel->remove(\*STDIN) == 1 or print "not "; -print "ok 4\n", -; -$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present - or print "not "; -print "ok 5\n"; - -print "not " unless $sel->count == 2; -print "ok 6\n"; -#print $sel->as_string, "\n"; - -$sel->remove(1, 4); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 7\n"; - -$sel = new IO::Select; -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 8\n"; - -$sel->remove([\*STDOUT, 5]); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 9\n"; - -if ($^O eq 'MSWin32' || $^O eq 'dos') { # 4-arg select is only valid on sockets - print "# skipping tests 10..15\n"; - for (10 .. 15) { print "ok $_\n" } - $sel->add(\*STDOUT); # update - goto POST_SOCKET; -} - -@a = $sel->can_read(); # should return imediately -print "not " unless @a == 0; -print "ok 10\n"; - -# we assume that we can write to STDOUT :-) -$sel->add([\*STDOUT, "ok 12\n"]); - -@a = $sel->can_write; -print "not " unless @a == 1; -print "ok 11\n"; - -my($fd, $msg) = @{shift @a}; -print $fd $msg; - -$sel->add(\*STDOUT); # update - -@a = IO::Select::select(undef, $sel, undef, 1); -print "not " unless @a == 3; -print "ok 13\n"; - -($r, $w, $e) = @a; - -print "not " unless @$r == 0 && @$w == 1 && @$e == 0; -print "ok 14\n"; - -$fd = $w->[0]; -print $fd "ok 15\n"; - -POST_SOCKET: -# Test new exists() method -$sel->exists(\*STDIN) and print "not "; -print "ok 16\n"; - -($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; -print "ok 17\n"; - -$fd = $sel->exists(\*STDOUT); -if ($fd) { - print $fd "ok 18\n"; -} else { - print "not ok 18\n"; -} - -$fd = $sel->exists([1, 'foo']); -if ($fd) { - print $fd "ok 19\n"; -} else { - print "not ok 19\n"; -} - -# Try self clearing -$sel->add(5,6,7,8,9,10); -print "not " unless $sel->count == 7; -print "ok 20\n"; - -$sel->remove($sel->handles); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 21\n"; - -# check warnings -$SIG{__WARN__} = sub { - ++ $w - if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ - } ; -$w = 0 ; -IO::Select::has_error(); -print "not " unless $w == 0 ; -$w = 0 ; -print "ok 22\n" ; -use warnings 'IO::Select' ; -IO::Select::has_error(); -print "not " unless $w == 1 ; -$w = 0 ; -print "ok 23\n" ; diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t deleted file mode 100755 index 45c16c2..0000000 --- a/contrib/perl5/t/lib/io_sock.t +++ /dev/null @@ -1,203 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../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'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; -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() or die "accept failed: $!"; - print "ok 2\n"; - - $sock->autoflush(1); - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost' - ) - || IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => '127.0.0.1' - ) - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - - $sock->autoflush(1); - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - 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") - || IO::Socket::INET->new("127.0.0.1:$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") - || IO::Socket->new(Domain => AF_INET, - PeerAddr => "127.0.0.1:$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') - || IO::Socket->new(Domain => AF_INET, - Proto => 'udp', - LocalAddr => '127.0.0.1'); -$port = $server->sockport; - -if ($^O eq 'mpeix') { - print("ok 12 # skipped\n") -} else { - if ($pid = fork()) { - my $buf; - $server->recv($buf, 100); - print $buf; - } elsif (defined($pid)) { - #child - $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port") - || IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "127.0.0.1:$port"); - $sock->send("ok 12\n"); - sleep(1); - $sock->send("ok 12\n"); # send another one to be sure - exit; - } else { - die; - } -} - -print "not " unless $server->blocking; -print "ok 13\n"; - -$server->blocking(0); -print "not " if $server->blocking; -print "ok 14\n"; diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t deleted file mode 100755 index 19afa2f..0000000 --- a/contrib/perl5/t/lib/io_taint.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl -T - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -END { unlink "./__taint__$$" } - -print "1..3\n"; -use IO::File; -$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -print $x "$$\n"; -$x->close; - -$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -chop($unsafe = <$x>); -eval { kill 0 * $unsafe }; -print "not " if $^O ne 'MSWin32' and ($@ !~ /^Insecure/o); -print "ok 1\n"; -$x->close; - -# We could have just done a seek on $x, but technically we haven't tested -# seek yet... -$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -$x->untaint; -print "not " if ($?); -print "ok 2\n"; # Calling the method worked -chop($unsafe = <$x>); -eval { kill 0 * $unsafe }; -print "not " if ($@ =~ /^Insecure/o); -print "ok 3\n"; # No Insecure message from using the data -$x->close; - -exit 0; diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t deleted file mode 100755 index 3aa4b03..0000000 --- a/contrib/perl5/t/lib/io_tell.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - $tell_file = "TEST"; - } - else { - $tell_file = "Makefile"; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -print "1..13\n"; - -use IO::File; - -$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos'); -if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } - -$firstline = <$tst>; -$secondpos = tell; - -$x = 0; -while (<$tst>) { - if (eof) {$x++;} -} -if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } - -$lastpos = tell; - -unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } - -if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } - -if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } - -if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } - -if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } - -if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } - -if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; } - -if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } - -if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } - -if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; } - -unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t deleted file mode 100755 index d63a5dc..0000000 --- a/contrib/perl5/t/lib/io_udp.t +++ /dev/null @@ -1,94 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - 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..7\n"; - -use Socket; -use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 1\n"; - -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 2\n"; - -$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; - -my @xtra = (); - -unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) { - print "not "; - @xtra = (0,$udpa->sockname); -} -print "ok 5\n"; - -$udpb->send("ok 6\n",@xtra); -$udpa->recv($buf="",5); -print $buf; - -print "not " if $udpa->connected; -print "ok 7\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t deleted file mode 100755 index 2f6def0..0000000 --- a/contrib/perl5/t/lib/io_unix.t +++ /dev/null @@ -1,89 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - elsif ($^O eq 'os2') { - require IO::Socket; - - eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1} - or $@ !~ /not implemented/ or - $reason = 'compiled without TCP/IP stack v4'; - } elsif ($^O eq 'qnx') { - $reason = 'Not implemented'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$PATH = "/tmp/sock-$$"; - -# Test if we can create the file within the tmp directory -if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') { - print "1..0 # Skip: cannot open '$PATH' for write\n"; - exit 0; -} -close(TEST); -unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; - -# Start testing -$| = 1; -print "1..5\n"; - -use IO::Socket; - -$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!"; -print "ok 1\n"; - -if($pid = fork()) { - - $sock = $listen->accept(); - print "ok 2\n"; - - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!"; - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!"; - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t deleted file mode 100755 index 2449fc4..0000000 --- a/contrib/perl5/t/lib/io_xs.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../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::File; -use IO::Seekable; - -print "1..4\n"; - -$x = new_tmpfile IO::File or print "not "; -print "ok 1\n"; -print $x "ok 2\n"; -$x->seek(0,SEEK_SET); -print <$x>; - -$x->seek(0,SEEK_SET); -print $x "not ok 3\n"; -$p = $x->getpos; -print $x "ok 3\n"; -$x->flush; -$x->setpos($p); -print scalar <$x>; - -$! = 0; -$x->setpos(undef); -print $! ? "ok 4 # $!\n" : "not ok 4\n"; - diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t deleted file mode 100755 index 795ad5d..0000000 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ /dev/null @@ -1,218 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - - @INC = '../lib'; - - require Config; import Config; - - my $reason; - - if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { - $reason = 'IPC::SysV was not built'; - } elsif ($Config{'d_sem'} ne 'define') { - $reason = '$Config{d_sem} undefined'; - } elsif ($Config{'d_msg'} ne 'define') { - $reason = '$Config{d_msg} undefined'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } -} - -# These constants are common to all tests. -# Later the sem* tests will import more for themselves. - -use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); -use strict; - -print "1..16\n"; - -my $msg; -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 = S_IRWXU; - -if ($Config{'d_msgget'} eq 'define' && - $Config{'d_msgctl'} eq 'define' && - $Config{'d_msgsnd'} eq 'define' && - $Config{'d_msgrcv'} eq 'define') { - - $msg = msgget(IPC_PRIVATE, $perm); - # Very first time called after machine is booted value may be 0 - die "msgget failed: $!\n" unless defined($msg) && $msg >= 0; - - print "ok 1\n"; - - #Putting a message on the queue - my $msgtype = 1; - my $msgtext = "hello"; - - my $test2bad; - my $test5bad; - my $test6bad; - - unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) { - print "not "; - $test2bad = 1; - } - print "ok 2\n"; - if ($test2bad) { - print <<EOM; -# -# The failure of the subtest #2 may indicate that the message queue -# resource limits either of the system or of the testing account -# have been reached. Error message "Operating would block" is -# usually indicative of this situation. The error message was now: -# "$!" -# -# You can check the message queues with the 'ipcs' command and -# you can remove unneeded queues with the 'ipcrm -q id' command. -# You may also consider configuring your system or account -# to have more message queue resources. -# -# Because of the subtest #2 failing also the substests #5 and #6 will -# very probably also fail. -# -EOM - } - - my $data; - msgctl($msg,IPC_STAT,$data) or print "not "; - print "ok 3\n"; - - print "not " unless length($data); - print "ok 4\n"; - - my $msgbuf; - unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { - print "not "; - $test5bad = 1; - } - print "ok 5\n"; - if ($test5bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } - - my($rmsgtype,$rmsgtext); - ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf); - unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { - print "not "; - $test6bad = 1; - } - print "ok 6\n"; - if ($test6bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } -} else { - for (1..6) { - print "ok $_\n"; # fake it - } -} - -if($Config{'d_semget'} eq 'define' && - $Config{'d_semctl'} eq 'define') { - - if ($Config{'d_semctl_semid_ds'} eq 'define' || - $Config{'d_semctl_semun'} eq 'define') { - - use IPC::SysV qw(IPC_CREAT GETALL SETALL); - - $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; - - print "ok 7\n"; - - 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; - - 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"; - - print "not " unless length($data) == length(pack("s!*",(0) x $nsem)); - print "ok 12\n"; - - my @data = unpack("s!*",$data); - - my $adata = "0" x $nsem; - - print "not " unless @data == $nsem and join("",@data) eq $adata; - print "ok 13\n"; - - my $poke = 2; - - $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 = unpack("s!*",$data); - - my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); - - 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 - } -} - -sub cleanup { - msgctl($msg,IPC_RMID,0) if defined $msg; - semctl($sem,0,IPC_RMID,undef) if defined $sem; -} - -cleanup; diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t deleted file mode 100755 index e56fcd9..0000000 --- a/contrib/perl5/t/lib/ndbm.t +++ /dev/null @@ -1,420 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bNDBM_File\b/) { - print "1..0 # Skip: NDBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require NDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..65\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h; -ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use NDBM_File; - @ISA=qw(NDBM_File); - @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ; '; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - 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 ; - use warnings ; - 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, ! defined $result{"fetch value"} ); - 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 ; - use warnings ; - 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*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use NDBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; -} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t deleted file mode 100755 index b935d04..0000000 --- a/contrib/perl5/t/lib/odbm.t +++ /dev/null @@ -1,437 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bODBM_File\b/) { - print "1..0 # Skip: ODBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require ODBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..66\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h; -ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use ODBM_File; - @ISA=qw(ODBM_File); - @EXPORT = @ODBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ;'; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - 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 ; - use warnings ; - 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, ! defined $result{"fetch value"} ); - 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 ; - use warnings ; - 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*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use ODBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - $h{ABC} = undef; - ok(66, $a eq "") ; - untie %h; - unlink <Op.dbmx*>; -} - -if ($^O eq 'hpux') { - print <<EOM; -# -# If you experience failures with the odbm test in HP-UX, -# this is a well-known bug that's unfortunately very hard to fix. -# The suggested course of action is to avoid using the ODBM_File, -# but to use instead the NDBM_File extension. -# -EOM -} diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t deleted file mode 100755 index a785fce..0000000 --- a/contrib/perl5/t/lib/opcode.t +++ /dev/null @@ -1,115 +0,0 @@ -#!./perl -w - -$|=1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use Opcode qw( - opcodes opdesc opmask verify_opset - opset opset_to_ops opset_to_hex invert_opset - opmask_add full_opset empty_opset define_optag -); - -use strict; - -my $t = 1; -my $last_test; # initalised at end -print "1..$last_test\n"; - -my($s1, $s2, $s3); -my(@o1, @o2, @o3); - -# --- opset_to_ops and opset - -my @empty_l = opset_to_ops(empty_opset); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l1 = opset_to_ops(full_opset); -print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed -print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; - -@empty_l = opset_to_ops(opset(':none')); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l3 = opset_to_ops(opset(':all')); -print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; -print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; - -die $t unless $t == 7; -$s1 = opset( 'padsv'); -$s2 = opset($s1, 'padav'); -$s3 = opset($s2, '!padav'); -print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; -print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- define_optag - -print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; -define_optag(":_tst_", opset(qw(padsv padav padhv))); -print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- opdesc and opcodes - -die $t unless $t == 11; -print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; -my @desc = opdesc(':_tst_','stub'); -print "@desc" eq "private variable private array private hash stub" - ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; -print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -print "ok $t\n"; ++$t; - -# --- invert_opset - -$s1 = opset(qw(fileno padsv padav)); -@o2 = opset_to_ops(invert_opset($s1)); -print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- opmask - -die $t unless $t == 16; -print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work -print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- verify_opset - -print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; - -# --- opmask_add - -opmask_add(opset(qw(fileno))); # add to global op_mask -print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail -print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; - -# --- check use of bit vector ops on opsets - -$s1 = opset('padsv'); -$s2 = opset('padav'); -$s3 = opset('padsv', 'padav', 'padhv'); - -# Non-negated -print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; - -# Negated, e.g., with possible extra bits in last byte beyond last op bit. -# The extra bits mean we can't just say ~mask eq invert_opset(mask). - -@o1 = opset_to_ops( ~ $s3); -@o2 = opset_to_ops(invert_opset $s3); -print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; - -# --- finally, check some opname assertions - -foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } - -print "ok $last_test\n"; -BEGIN { $last_test = 25 } diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t deleted file mode 100755 index 85b807c..0000000 --- a/contrib/perl5/t/lib/open2.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (!$Config{'d_fork'} - # open2/3 supported on win32 (but not Borland due to CRT bugs) - && ($^O ne 'MSWin32' || $Config{'cc'} =~ /^bcc/i)) - { - print "1..0\n"; - exit 0; - } - # make warnings fatal - $SIG{__WARN__} = sub { die @_ }; -} - -use strict; -use IO::Handle; -use IPC::Open2; -#require 'open2.pl'; use subs 'open2'; - -my $perl = './perl'; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -sub cmd_line { - if ($^O eq 'MSWin32') { - return qq/"$_[0]"/; - } - else { - return $_[0]; - } -} - -my ($pid, $reaped_pid); -STDOUT->autoflush; -STDERR->autoflush; - -print "1..7\n"; - -ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', - cmd_line('print scalar <STDIN>'); -ok 2, print WRITE "hi kid\n"; -ok 3, <READ> =~ /^hi kid\r?\n$/; -ok 4, close(WRITE), $!; -ok 5, close(READ), $!; -$reaped_pid = waitpid $pid, 0; -ok 6, $reaped_pid == $pid, $reaped_pid; -ok 7, $? == 0, $?; diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t deleted file mode 100755 index a0da34f..0000000 --- a/contrib/perl5/t/lib/open3.t +++ /dev/null @@ -1,150 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (!$Config{'d_fork'} - # open2/3 supported on win32 (but not Borland due to CRT bugs) - && ($^O ne 'MSWin32' || $Config{'cc'} =~ /^bcc/i)) - { - print "1..0\n"; - exit 0; - } - # make warnings fatal - $SIG{__WARN__} = sub { die @_ }; -} - -use strict; -use IO::Handle; -use IPC::Open3; -#require 'open3.pl'; use subs 'open3'; - -my $perl = $^X; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -sub cmd_line { - if ($^O eq 'MSWin32') { - my $cmd = shift; - $cmd =~ tr/\r\n//d; - $cmd =~ s/"/\\"/g; - return qq/"$cmd"/; - } - else { - return $_[0]; - } -} - -my ($pid, $reaped_pid); -STDOUT->autoflush; -STDERR->autoflush; - -print "1..22\n"; - -# basic -ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR "hi error\n"; -EOF -ok 2, print WRITE "hi kid\n"; -ok 3, <READ> =~ /^hi kid\r?\n$/; -ok 4, <ERROR> =~ /^hi error\r?\n$/; -ok 5, close(WRITE), $!; -ok 6, close(READ), $!; -ok 7, close(ERROR), $!; -$reaped_pid = waitpid $pid, 0; -ok 8, $reaped_pid == $pid, $reaped_pid; -ok 9, $? == 0, $?; - -# read and error together, both named -$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 10\n"; -print scalar <READ>; -print WRITE "ok 11\n"; -print scalar <READ>; -waitpid $pid, 0; - -# read and error together, error empty -$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 12\n"; -print scalar <READ>; -print WRITE "ok 13\n"; -print scalar <READ>; -waitpid $pid, 0; - -# dup writer -ok 14, pipe PIPE_READ, PIPE_WRITE; -$pid = open3 '<&PIPE_READ', 'READ', '', - $perl, '-e', cmd_line('print scalar <STDIN>'); -close PIPE_READ; -print PIPE_WRITE "ok 15\n"; -close PIPE_WRITE; -print scalar <READ>; -waitpid $pid, 0; - -# dup reader -$pid = open3 'WRITE', '>&STDOUT', 'ERROR', - $perl, '-e', cmd_line('print scalar <STDIN>'); -print WRITE "ok 16\n"; -waitpid $pid, 0; - -# dup error: This particular case, duping stderr onto the existing -# stdout but putting stdout somewhere else, is a good case because it -# used not to work. -$pid = open3 'WRITE', 'READ', '>&STDOUT', - $perl, '-e', cmd_line('print STDERR scalar <STDIN>'); -print WRITE "ok 17\n"; -waitpid $pid, 0; - -# dup reader and error together, both named -$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print STDOUT scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 18\n"; -print WRITE "ok 19\n"; -waitpid $pid, 0; - -# dup reader and error together, error empty -$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print STDOUT scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 20\n"; -print WRITE "ok 21\n"; -waitpid $pid, 0; - -# command line in single parameter variant of open3 -# for understanding of Config{'sh'} test see exec description in camel book -my $cmd = 'print(scalar(<STDIN>))'; -$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); -eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; }; -if ($@) { - print "error $@\n"; - print "not ok 22\n"; -} -else { - print WRITE "ok 22\n"; - waitpid $pid, 0; -} diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t deleted file mode 100755 index 56b1bac..0000000 --- a/contrib/perl5/t/lib/ops.t +++ /dev/null @@ -1,29 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -print "1..2\n"; - -eval <<'EOP'; - no ops 'fileno'; # equiv to "perl -M-ops=fileno" - $a = fileno STDIN; -EOP - -print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; - -eval <<'EOP'; - use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" - eval 1; -EOP - -print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; - -1; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t deleted file mode 100755 index 261d81f..0000000 --- a/contrib/perl5/t/lib/parsewords.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use Text::ParseWords; - -print "1..18\n"; - -@words = shellwords(qq(foo "bar quiz" zoo)); -print "not " if $words[0] ne 'foo'; -print "ok 1\n"; -print "not " if $words[1] ne 'bar quiz'; -print "ok 2\n"; -print "not " if $words[2] ne 'zoo'; -print "ok 3\n"; - -{ - # Gonna get some undefined things back - no warnings 'uninitialized' ; - - # Test quotewords() with other parameters and null last field - @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); - print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); - print "ok 4\n"; -} - -# Test $keep eq 'delimiters' and last field zero -@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); -print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); -print "ok 5\n"; - -# Big ol' nasty test (thanks, Joerk!) -$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; - -# First with $keep == 1 -$result = join('|', parse_line('\s+', 1, $string)); -print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; -print "ok 6\n"; - -# Now, $keep == 0 -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; -print "ok 7\n"; - -# Now test single quote behavior -$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 8\n"; - -# Make sure @nested_quotewords does the right thing -@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); -print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); -print "ok 9\n"; - -# Now test error return -$string = 'foo bar baz"bach blech boop'; - -@words = shellwords($string); -print "not " if (@words); -print "ok 10\n"; - -@words = parse_line('s+', 0, $string); -print "not " if (@words); -print "ok 11\n"; - -@words = quotewords('s+', 0, $string); -print "not " if (@words); -print "ok 12\n"; - -{ - # Gonna get some more undefined things back - no warnings 'uninitialized' ; - - @words = nested_quotewords('s+', 0, $string); - print "not " if (@words); - print "ok 13\n"; - - # Now test empty fields - $result = join('|', parse_line(':', 0, 'foo::0:"":::')); - print "not " unless ($result eq 'foo||0||||'); - print "ok 14\n"; - - # Test for 0 in quotes without $keep - $result = join('|', parse_line(':', 0, ':"0":')); - print "not " unless ($result eq '|0|'); - print "ok 15\n"; - - # Test for \001 in quoted string - $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); - print "not " unless ($result eq "|\1|"); - print "ok 16\n"; - -} - -# Now test perlish single quote behavior -$Text::ParseWords::PERL_SINGLE_QUOTE = 1; -$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/contrib/perl5/t/lib/peek.t b/contrib/perl5/t/lib/peek.t deleted file mode 100755 index fe9cb2c..0000000 --- a/contrib/perl5/t/lib/peek.t +++ /dev/null @@ -1,312 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bPeek\b/) { - print "1..0 # Skip: Devel::Peek was not built\n"; - exit 0; - } -} - -use Devel::Peek; - -print "1..17\n"; - -our $DEBUG = 0; -open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; - -sub do_test { - my $pattern = pop; - if (open(OUT,">peek$$")) { - open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; - Dump($_[1]); - open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; - close(OUT); - if (open(IN, "peek$$")) { - local $/; - $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; - print $pattern, "\n" if $DEBUG; - my $dump = <IN>; - print $dump, "\n" if $DEBUG; - print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/ms; - print "ok $_[0]\n"; - close(IN); - } else { - die "$0: failed to open peek$$: !\n"; - } - } else { - die "$0: failed to create peek$$: $!\n"; - } -} - -our $a; -our $b; -my $c; -local $d = 0; - -do_test( 1, - $a = "foo", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4' - ); - -do_test( 2, - "bar", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*POK,READONLY,pPOK\\) - PV = $ADDR "bar"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 3, - $b = 123, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123'); - -do_test( 4, - 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) - IV = 456'); - -do_test( 5, - $c = 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\) - IV = 456'); - -do_test( 6, - $c + $d, -'SV = NV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADTMP,NOK,pNOK\\) - NV = 456'); - -($d = "789") += 0.1; - -do_test( 7, - $d, -'SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(NOK,pNOK\\) - IV = 0 - NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) - PV = $ADDR "789"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 8, - 0xabcd, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) - UV = 43981'); - -do_test( 9, - undef, -'SV = NULL\\(0x0\\) at $ADDR - REFCNT = 1 - FLAGS = \\(\\)'); - -do_test(10, - \$a, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4'); - -do_test(11, - [$b,$c], -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVAV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(\\) - IV = 0 - NV = 0 - ARRAY = $ADDR - FILL = 1 - MAX = 1 - ARYLEN = 0x0 - FLAGS = \\(REAL\\) - Elt No. 0 - SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123 - Elt No. 1 - SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); - -do_test(12, - {$b=>$c}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(SHAREKEYS\\) - IV = 1 - NV = 0 - ARRAY = $ADDR \\(0:7, 1:1\\) - hash quality = 150.0% - KEYS = 1 - FILL = 1 - MAX = 7 - RITER = -1 - EITER = 0x0 - Elt "123" HASH = $ADDR - SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); - -do_test(13, - sub(){@_}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON\\) - IV = 0 - NV = 0 - PROTOTYPE = "" - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 0 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x4 - PADLIST = $ADDR - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(14, - \&do_test, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = (3|4) - FLAGS = \\(\\) - IV = 0 - NV = 0 - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "do_test" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 1 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x0 - PADLIST = $ADDR - \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\) - \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\) - \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\) - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(15, - qr(tic), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVMG\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(OBJECT,RMG\\) - IV = 0 - NV = 0 - PV = 0 - MAGIC = $ADDR - MG_VIRTUAL = $ADDR - MG_TYPE = \'r\' - MG_OBJ = $ADDR - STASH = $ADDR\\t"Regexp"'); - -do_test(16, - (bless {}, "Tac"), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(OBJECT,SHAREKEYS\\) - IV = 0 - NV = 0 - STASH = $ADDR\\t"Tac" - ARRAY = 0x0 - KEYS = 0 - FILL = 0 - MAX = 7 - RITER = -1 - EITER = 0x0'); - -do_test(17, - *a, -'SV = PVGV\\($ADDR\\) at $ADDR - REFCNT = 5 - FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) - IV = 0 - NV = 0 - MAGIC = $ADDR - MG_VIRTUAL = &PL_vtbl_glob - MG_TYPE = \'\\*\' - MG_OBJ = $ADDR - NAME = "a" - NAMELEN = 1 - GvSTASH = $ADDR\\t"main" - GP = $ADDR - SV = $ADDR - REFCNT = 1 - IO = 0x0 - FORM = 0x0 - AV = 0x0 - HV = 0x0 - CV = 0x0 - CVGEN = 0x0 - GPFLAGS = 0x0 - LINE = \\d+ - FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR - EGV = $ADDR\\t"a"'); - -END { - 1 while unlink("peek$$"); -} diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t deleted file mode 100755 index de27dee..0000000 --- a/contrib/perl5/t/lib/ph.t +++ /dev/null @@ -1,96 +0,0 @@ -#!./perl - -# Check for presence and correctness of .ph files; for now, -# just socket.ph and pals. -# -- Kurt Starsinic <kstar@isinet.com> - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# 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 - AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK - AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP - AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB - MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI - PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT - PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM - SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN - SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR - SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO - SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK -); - - -# The libraries which I'm going to require: -my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph"); - - -# These are defined by Socket.pm even if the C header files don't define them: -my %ok_to_miss = ( - INADDR_NONE => 1, - INADDR_LOOPBACK => 1, -); - - -my $total_tests = scalar @libs + scalar @possibly_defined; -my $i = 0; - -print "1..$total_tests\n"; - - -foreach (@libs) { - $i++; - - if (eval "require $_" ) { - print "ok $i\n"; - } else { - print "# Skipping tests; $_ may be missing\n"; - foreach ($i .. $total_tests) { print "ok $_\n" } - exit; - } -} - - -foreach (@possibly_defined) { - $i++; - - $pm_val = eval "Socket::$_()"; - $ph_val = eval "main::$_()"; - - if (defined $pm_val and !defined $ph_val) { - if ($ok_to_miss{$_}) { print "ok $i\n" } - else { print "not ok $i\n" } - next; - } elsif (defined $ph_val and !defined $pm_val) { - print "not ok $i\n"; - next; - } - - # Socket.pm converts these to network byte order, so we convert the - # socket.ph version to match; note that these cases skip the following - # `elsif', which is only applied to _numeric_ values, not literal - # bitmasks. - if ($_ eq 'INADDR_ANY' - or $_ eq 'INADDR_LOOPBACK' - or $_ eq 'INADDR_NONE') { - $ph_val = pack("N*", $ph_val); # htonl(3) equivalent - } - - # Since Socket.pm and socket.ph wave their hands over macros differently, - # they could return functionally equivalent bitmaps with different numeric - # interpretations (due to sign extension). The only apparent case of this - # is SO_DONTLINGER (only on Solaris, and deprecated, at that): - elsif ($pm_val != $ph_val) { - $pm_val = oct(sprintf "0x%lx", $pm_val); - $ph_val = oct(sprintf "0x%lx", $ph_val); - } - - if ($pm_val == $ph_val) { print "ok $i\n" } - else { print "not ok $i\n" } -} - - diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t deleted file mode 100755 index 994704a..0000000 --- a/contrib/perl5/t/lib/posix.t +++ /dev/null @@ -1,137 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { - print "1..0\n"; - exit 0; - } -} - -use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); -use strict subs; - -$| = 1; -print "1..27\n"; - -$Is_W32 = $^O eq 'MSWin32'; -$Is_Dos = $^O eq 'dos'; - -$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; -read($testfd, $buffer, 9) if $testfd > 2; -print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; - -write(1,"ok 3\nnot ok 3\n", 5); - -if ($Is_Dos) { - for (4..5) { - print "ok $_ # skipped, no pipe() support on dos\n"; - } -} else { -@fds = POSIX::pipe(); -print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; -CORE::open($reader = \*READER, "<&=".$fds[0]); -CORE::open($writer = \*WRITER, ">&=".$fds[1]); -print $writer "ok 5\n"; -close $writer; -print <$reader>; -close $reader; -} - -if ($Is_W32 || $Is_Dos) { - for (6..11) { - print "ok $_ # skipped, no sigaction support on win32/dos\n"; - } -} -else { -$sigset = new POSIX::SigSet 1,3; -delset $sigset 1; -if (!ismember $sigset 1) { print "ok 6\n" } -if (ismember $sigset 3) { print "ok 7\n" } -$mask = new POSIX::SigSet &SIGINT; -$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; -sigaction(&SIGHUP, $action); -$SIG{'INT'} = 'SigINT'; -kill 'HUP', $$; -sleep 1; -print "ok 11\n"; - -sub SigHUP { - print "ok 8\n"; - kill 'INT', $$; - sleep 2; - print "ok 9\n"; -} - -sub SigINT { - print "ok 10\n"; -} -} - -print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; - -print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; - -# Check string conversion functions. - -if ($Config{d_strtod}) { - $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; - ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); -# Using long double NVs may introduce greater accuracy than wanted. - $n =~ s/^3.14158999\d*$/3.14159/ - if $Config{uselongdouble} eq 'define'; - print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n"); - &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; -} else { print "# strtod not present\n", "ok 14\n"; } - -if ($Config{d_strtol}) { - ($n, $x) = &POSIX::strtol('21_PENGUINS'); - print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n"); -} else { print "# strtol not present\n", "ok 15\n"; } - -if ($Config{d_strtoul}) { - ($n, $x) = &POSIX::strtoul('88_TEARS'); - print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n"); -} else { print "# strtoul not present\n", "ok 16\n"; } - -# Pick up whether we're really able to dynamically load everything. -print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; - -# This can coredump if struct tm has a timezone field and we -# didn't detect it. If this fails, try adding -# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c. -# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl -print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); - -# If that worked, validate the mini_mktime() routine's normalisation of -# input fields to strftime(). -sub try_strftime { - my $num = shift; - my $expect = shift; - my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); - if ($got eq $expect) { - print "ok $num\n"; - } - else { - print "# expected: $expect\n# got: $got\nnot ok $num\n"; - } -} - -$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; -try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); -try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); -try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); -try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); -try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); -try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); -try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); -try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); -try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); -&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; - -$| = 0; -# The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); -_exit(0); diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t deleted file mode 100755 index 27993d9..0000000 --- a/contrib/perl5/t/lib/safe1.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -# Tests Todo: -# 'main' as root - -package test; # test from somewhere other than main - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -my $t = 1; -my $cpt; -# create and destroy some automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root" or die; - -foreach(1..3) { - $foo = 42; - - $cpt->share(qw($foo)); - - print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; - - ${$cpt->varglob('foo')} = 9; - - print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - - print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check 'main' has been changed: - print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check we can't see our test package: - print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; - print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; - - $cpt->erase; # erase the compartment, e.g., delete all variables - - print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; - - # Note that we *must* use $cpt->varglob here because if we used - # $Root::foo etc we would still see the original values! - # This seems to be because the compiler has created an extra ref. - - print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; -} - -print "ok $last_test\n"; -BEGIN { $last_test = 28 } diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t deleted file mode 100755 index 4d6c84a..0000000 --- a/contrib/perl5/t/lib/safe2.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @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'; - $ENV{LANGUAGE} = 'C'; # GNU locale extension -} - -# Tests Todo: -# 'main' as root - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -# Set up a package namespace of things to be visible to the unsafe code -$Root::foo = "visible"; -$bar = "invisible"; - -# Stop perl from moaning about identifies which are apparently only used once -$Root::foo .= ""; - -my $cpt; -# create and destroy a couple of automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root"; - -$cpt->reval(q{ system("echo not ok 1"); }); -if ($@ =~ /^system trapped by operation mask/) { - print "ok 1\n"; -} else { - print "#$@" if $@; - print "not ok 1\n"; -} - -$cpt->reval(q{ - print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; - print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; - print defined($bar) ? "not ok 4\n" : "ok 4\n"; - print defined($::bar) ? "not ok 5\n" : "ok 5\n"; - print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; -}); -print $@ ? "not ok 7\n#$@" : "ok 7\n"; - -$foo = "ok 8\n"; -%bar = (key => "ok 9\n"); -@baz = (); push(@baz, "o", "10"); $" = 'k '; -$glob = "ok 11\n"; -@glob = qw(not ok 16); - -sub sayok { print "ok @_\n" } - -$cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{use5005threads}; - -$cpt->reval(q{ - package other; - sub other_sayok { print "ok @_\n" } - package main; - print $foo ? $foo : "not ok 8\n"; - print $bar{key} ? $bar{key} : "not ok 9\n"; - (@baz) ? print "@baz\n" : print "not ok 10\n"; - print $glob; - other::other_sayok(12); - $foo =~ s/8/14/; - $bar{new} = "ok 15\n"; - @glob = qw(ok 16); -}); -print $@ ? "not ok 13\n#$@" : "ok 13\n"; -$" = ' '; -print $foo, $bar{new}, "@glob\n"; - -$Root::foo = "not ok 17"; -@{$cpt->varglob('bar')} = qw(not ok 18); -${$cpt->varglob('foo')} = "ok 17"; -@Root::bar = "ok"; -push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." - -print "$Root::foo\n"; -print "@{$cpt->varglob('bar')}\n"; - -use strict; - -print 1 ? "ok 19\n" : "not ok 19\n"; -print 1 ? "ok 20\n" : "not ok 20\n"; - -my $m1 = $cpt->mask; -$cpt->trap("negate"); -my $m2 = $cpt->mask; -my @masked = opset_to_ops($m1); -print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; - -print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; - -print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; - -$cpt->mask(empty_opset); -my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); -print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; -my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); -print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; - -my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); -print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; -print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; - -# --- rdo - -my $t = 30; -$cpt->rdo('/non/existant/file.name'); -# The regexp is getting rather baroque. -print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; -# test #31 is gone. -print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; - -#my $rdo_file = "tmp_rdo.tpl"; -#if (open X,">$rdo_file") { -# print X "999\n"; -# close X; -# $cpt->permit_only('const', 'leaveeval'); -# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; -# unlink $rdo_file; -#} -#else { -# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; -#} - - -print "ok $last_test\n"; -BEGIN { $last_test = 32 } diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t deleted file mode 100755 index 3221ca4..0000000 --- a/contrib/perl5/t/lib/sdbm.t +++ /dev/null @@ -1,429 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ - print "1..0\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require SDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..68\n"; - -unlink <Op_dbmx.*>; - -umask(0); -my %h ; -ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); - -my $Dfile = "Op_dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op_dbmx.*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use SDBM_File; - @ISA=qw(SDBM_File); - @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ;'; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - 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 ; - use warnings ; - 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 ; - use warnings ; - 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, ! defined $result{"fetch value"} ); - 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 ; - use warnings ; - 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*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use SDBM_File ; - - unlink <Op_dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - $h{ABC} = undef; - ok(68, $a eq "") ; - - untie %h; - unlink <Op_dbmx*>; -} diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t deleted file mode 100755 index c36fdb8..0000000 --- a/contrib/perl5/t/lib/searchdict.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..4\n"; - -$DICT = <<EOT; -Aarhus -Aaron -Ababa -aback -abaft -abandon -abandoned -abandoning -abandonment -abandons -abase -abased -abasement -abasements -abases -abash -abashed -abashes -abashing -abasing -abate -abated -abatement -abatements -abater -abates -abating -Abba -EOT - -use Search::Dict; - -open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; -binmode DICT; # To make length expected one. -print DICT $DICT; - -my $pos = look *DICT, "Ababa"; -chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "Ababa"; -print "ok 1\n"; - -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"; - - 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 4\n"; - -close DICT or die "cannot close"; -unlink "dict-$$"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t deleted file mode 100755 index 3b58d70..0000000 --- a/contrib/perl5/t/lib/selectsaver.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..3\n"; - -use SelectSaver; - -open(FOO, ">foo-$$") || die; - -print "ok 1\n"; -{ - my $saver = new SelectSaver(FOO); - print "foo\n"; -} - -# Get data written to file -open(FOO, "foo-$$") || die; -chomp($foo = <FOO>); -close FOO; -unlink "foo-$$"; - -print "ok 2\n" if $foo eq "foo"; - -print "ok 3\n"; diff --git a/contrib/perl5/t/lib/selfloader.t b/contrib/perl5/t/lib/selfloader.t deleted file mode 100755 index 6b9c244..0000000 --- a/contrib/perl5/t/lib/selfloader.t +++ /dev/null @@ -1,201 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - $dir = "self-$$"; - @INC = $dir; - push @INC, '../lib'; - - print "1..19\n"; - - # First we must set up some selfloader files - mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; - - open(FOO, ">$dir/Foo.pm") or die; - print FOO <<'EOT'; -package Foo; -use SelfLoader; - -sub new { bless {}, shift } -sub foo; -sub bar; -sub bazmarkhianish; -sub a; -sub never; # declared but definition should never be read -1; -__DATA__ - -sub foo { shift; shift || "foo" }; - -sub bar { shift; shift || "bar" } - -sub bazmarkhianish { shift; shift || "baz" } - -package sheep; -sub bleat { shift; shift || "baa" } - -__END__ -sub never { die "D'oh" } -EOT - - close(FOO); - - open(BAR, ">$dir/Bar.pm") or die; - print BAR <<'EOT'; -package Bar; -use SelfLoader; - -@ISA = 'Baz'; - -sub new { bless {}, shift } -sub a; - -1; -__DATA__ - -sub a { 'a Bar'; } -sub b { 'b Bar' } - -__END__ DATA -sub never { die "D'oh" } -EOT - - close(BAR); -}; - - -package Baz; - -sub a { 'a Baz' } -sub b { 'b Baz' } -sub c { 'c Baz' } - - -package main; -use Foo; -use Bar; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # selfloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 3\n"; -} else { - print "not ok 3 $@\n"; -} - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -if ($@ =~ /oops/) { - print "ok 4\n"; -} else { - print "not ok 4 $@\n"; -} - -# Pass regular expression variable to autoloaded function. This used -# to go wrong in AutoLoader because it used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# Check nested packages inside __DATA__ -print "not " unless sheep::bleat() eq 'baa'; -print "ok 10\n"; - -# Now check inheritance: - -$bar = new Bar; - -# Before anything is SelfLoaded there is no declaration of Foo::b so we should -# get Baz::b -print "not " unless $bar->b() eq 'b Baz'; -print "ok 11\n"; - -# There is no Bar::c so we should get Baz::c -print "not " unless $bar->c() eq 'c Baz'; -print "ok 12\n"; - -# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side -# effect -print "not " unless $bar->a() eq 'a Bar'; -print "ok 13\n"; - -print "not " unless $bar->b() eq 'b Bar'; -print "ok 14\n"; - -print "not " unless $bar->c() eq 'c Baz'; -print "ok 15\n"; - - - -# Check that __END__ is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $foo->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 16\n"; -} else { - print "not ok 16 $@\n"; -} - -# Try to read from the data file handle -my $foodata = <Foo::DATA>; -close Foo::DATA; -if (defined $foodata) { - print "not ok 17 # $foodata\n"; -} else { - print "ok 17\n"; -} - -# Check that __END__ DATA is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $bar->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 18\n"; -} else { - print "not ok 18 $@\n"; -} - -# Try to read from the data file handle -my $bardata = <Bar::DATA>; -close Bar::DATA; -if ($bardata ne "sub never { die \"D'oh\" }\n") { - print "not ok 19 # $bardata\n"; -} else { - print "ok 19\n"; -} - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir/Foo.pm", "$dir/Bar.pm"; -rmdir "$dir"; -} diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t deleted file mode 100755 index 481fd8f..0000000 --- a/contrib/perl5/t/lib/socket.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSocket\b/ && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; - exit 0; - } -} - -use Socket; - -print "1..8\n"; - -if (socket(T,PF_INET,SOCK_STREAM,6)) { - print "ok 1\n"; - - if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ - print "ok 2\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; - - syswrite(T,"hello",5); - $read = sysread(T,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(T,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "hello") ? "ok 3\n" : "not ok 3\n"); - } - else { - print "# You're allowed to fail tests 2 and 3 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 2\n"; - print "ok 3\n"; - } -} -else { - print "# $!\n"; - print "not ok 1\n"; -} - -if( socket(S,PF_INET,SOCK_STREAM,6) ){ - print "ok 4\n"; - - if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ - print "ok 5\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; - - syswrite(S,"olleh",5); - $read = sysread(S,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(S,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "olleh") ? "ok 6\n" : "not ok 6\n"); - } - else { - print "# You're allowed to fail tests 5 and 6 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 5\n"; - print "ok 6\n"; - } -} -else { - print "# $!\n"; - print "not ok 4\n"; -} - -# warnings -$SIG{__WARN__} = sub { - ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; -} ; -$w = 0 ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; -use warnings 'Socket' ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t deleted file mode 100755 index d35f264..0000000 --- a/contrib/perl5/t/lib/soundex.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl -# -# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ -# -# test module for soundex.pl -# -# $Log: soundex.t,v $ -# Revision 1.2 1994/03/24 00:30:27 mike -# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -# in the way I handles leasing characters which were different but had -# the same soundex code. This showed up comparing it with Oracle's -# soundex output. -# -# Revision 1.1 1994/03/02 13:03:02 mike -# Initial revision -# -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Soundex; - -$test = 0; -print "1..13\n"; - -while (<DATA>) -{ - chop; - next if /^\s*;?#/; - next if /^\s*$/; - - ++$test; - $bad = 0; - - if (/^eval\s+/) - { - ($try = $_) =~ s/^eval\s+//; - - eval ($try); - if ($@) - { - $bad++; - print "not ok $test\n"; - print "# eval '$try' returned $@"; - } - } - elsif (/^\(/) - { - ($in, $out) = split (':'); - - $try = "\@expect = $out; \@got = &soundex $in;"; - eval ($try); - - if (@expect != @got) - { - $bad++; - print "not ok $test\n"; - print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; - print "# expected (", join (', ', @expect), - ") got (", join (', ', @got), ")\n"; - } - else - { - while (@got) - { - $expect = shift @expect; - $got = shift @got; - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - } - } - else - { - ($in, $out) = split (':'); - - $try = "\$expect = $out; \$got = &soundex ($in);"; - eval ($try); - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - - print "ok $test\n" unless $bad; -} - -__END__ -# -# 1..6 -# -# Knuth's test cases, scalar in, scalar out -# -'Euler':'E460' -'Gauss':'G200' -'Hilbert':'H416' -'Knuth':'K530' -'Lloyd':'L300' -'Lukasiewicz':'L222' -# -# 7..8 -# -# check default bad code -# -'2 + 2 = 4':undef -undef:undef -# -# 9 -# -# check array in, array out -# -('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') -# -# 10 -# -# check array with explicit undef -# -('Mike', undef, 'Stok'):('M200', undef, 'S320') -# -# 11..12 -# -# check setting $Text::Soundex::noCode -# -eval $soundex_nocode = 'Z000'; -('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') -# -# 13 -# -# a subtle difference between me & oracle, spotted by Rich Pinder -# <rpinder@hsc.usc.edu> -# -CZARKOWSKA:C622 diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t deleted file mode 100755 index 03449a3..0000000 --- a/contrib/perl5/t/lib/symbol.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..8\n"; - -BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_ - -use Symbol; - -# First check $_ clobbering -print "not " if $_ ne 'foo'; -print "ok 1\n"; - - -# First test gensym() -$sym1 = gensym; -print "not " if ref($sym1) ne 'GLOB'; -print "ok 2\n"; - -$sym2 = gensym; - -print "not " if $sym1 eq $sym2; -print "ok 3\n"; - -ungensym $sym1; - -$sym1 = $sym2 = undef; - - -# Test qualify() -package foo; - -use Symbol qw(qualify); # must import into this package too - -qualify("x") eq "foo::x" or print "not "; -print "ok 4\n"; - -qualify("x", "FOO") eq "FOO::x" or print "not "; -print "ok 5\n"; - -qualify("BAR::x") eq "BAR::x" or print "not "; -print "ok 6\n"; - -qualify("STDOUT") eq "main::STDOUT" or print "not "; -print "ok 7\n"; - -qualify("ARGV", "FOO") eq "main::ARGV" or print "not "; -print "ok 8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t deleted file mode 100755 index 2bdb69d..0000000 --- a/contrib/perl5/t/lib/syslfs.t +++ /dev/null @@ -1,265 +0,0 @@ -# NOTE: this file tests how large files (>2GB) work with raw system IO. -# stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t. -# If you modify/add tests here, remember to update also t/op/lfs.t. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - # Don't bother if there are no quad offsets. - if ($Config{lseeksize} < 8) { - print "1..0 # Skip: no 64-bit file offsets\n"; - exit(0); - } - require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); -} - -use strict; - -our @s; -our $fail; - -sub zap { - close(BIG); - unlink("big"); - unlink("big1"); - unlink("big2"); -} - -sub bye { - zap(); - exit(0); -} - -my $explained; - -sub explain { - unless ($explained++) { - print <<EOM; -# -# If the lfs (large file support: large meaning larger than two -# gigabytes) tests are skipped or fail, it may mean either that your -# process (or process group) is not allowed to write large files -# (resource limits) or that the file system (the network filesystem?) -# you are running the tests on doesn't let your user/group have large -# files (quota) or the filesystem simply doesn't support large files. -# You may even need to reconfigure your kernel. (This is all very -# operating system and site-dependent.) -# -# Perl may still be able to support large files, once you have -# such a process, enough quota, and such a (file) system. -# It is just that the test failed now. -# -EOM - } - print "1..0 # Skip: @_\n" if @_; -} - -print "# checking whether we have sparse files...\n"; - -# Known have-nots. -if ($^O eq 'MSWin32' || $^O eq 'VMS') { - print "1..0 # Skip: no sparse files in $^O\n"; - bye(); -} - -# Known haves that have problems running this test -# (for example because they do not support sparse files, like UNICOS) -if ($^O eq 'unicos') { - print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; - bye(); -} - -# Then try heuristically to deduce whether we have sparse files. - -# We'll start off by creating a one megabyte file which has -# only three "true" bytes. If we have sparseness, we should -# consume less blocks than one megabyte (assuming nobody has -# one megabyte blocks...) - -sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen big1 failed: $!\n"; bye }; -sysseek(BIG, 1_000_000, SEEK_SET) or - do { warn "sysseek big1 failed: $!\n"; bye }; -syswrite(BIG, "big") or - do { warn "syswrite big1 failed; $!\n"; bye }; -close(BIG) or - do { warn "close big1 failed: $!\n"; bye }; - -my @s1 = stat("big1"); - -print "# s1 = @s1\n"; - -sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen big2 failed: $!\n"; bye }; -sysseek(BIG, 2_000_000, SEEK_SET) or - do { warn "sysseek big2 failed: $!\n"; bye }; -syswrite(BIG, "big") or - do { warn "syswrite big2 failed; $!\n"; bye }; -close(BIG) or - do { warn "close big2 failed: $!\n"; bye }; - -my @s2 = stat("big2"); - -print "# s2 = @s2\n"; - -zap(); - -unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && - $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0 # Skip: no sparse files?\n"; - bye; -} - -print "# we seem to have sparse files...\n"; - -# By now we better be sure that we do have sparse files: -# if we are not, the following will hog 5 gigabytes of disk. Ooops. -# This may fail by producing some signal; run in a subprocess first for safety - -$ENV{LC_ALL} = "C"; - -my $r = system '../perl', '-I../lib', '-e', <<'EOF'; -use Fcntl qw(/^O_/ /^SEEK_/); -sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; -my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -my $syswrite = syswrite(BIG, "big"); -exit 0; -EOF - -sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen 'big' failed: $!\n"; bye }; -my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { - $sysseek = 'undef' unless defined $sysseek; - explain("seeking past 2GB failed: ", - $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); - bye(); -} - -# The syswrite will fail if there are are filesize limitations (process or fs). -my $syswrite = syswrite(BIG, "big"); -print "# syswrite failed: $! (syswrite returned ", - defined $syswrite ? $syswrite : 'undef', ")\n" - unless defined $syswrite && $syswrite == 3; -my $close = close BIG; -print "# close failed: $!\n" unless $close; -unless($syswrite && $close) { - if ($! =~/too large/i) { - explain("writing past 2GB failed: process limits?"); - } elsif ($! =~ /quota/i) { - explain("filesystem quota limits?"); - } else { - explain("error: $!"); - } - bye(); -} - -@s = stat("big"); - -print "# @s\n"; - -unless ($s[7] == 5_000_000_003) { - explain("kernel/fs not configured to use large files?"); - bye(); -} - -sub fail () { - print "not "; - $fail++; -} - -sub offset ($$) { - my ($offset_will_be, $offset_want) = @_; - my $offset_is = eval $offset_will_be; - unless ($offset_is == $offset_want) { - print "# bad offset $offset_is, want $offset_want\n"; - my ($offset_func) = ($offset_will_be =~ /^(\w+)/); - if (unpack("L", pack("L", $offset_want)) == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - print "# $offset_want cast into 32 bits equals $offset_is.\n"; - } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 - == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", - $offset_want, - $offset_want, - $offset_is; - } - fail; - } -} - -print "1..17\n"; - -$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 }; - -offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000); -print "ok 5\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); -print "ok 6\n"; - -offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001); -print "ok 7\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001); -print "ok 8\n"; - -offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000); -print "ok 9\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); -print "ok 10\n"; - -offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000); -print "ok 11\n"; - -offset('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 -# See that we don't have "big" in the 705_... spot: -# that would mean that we have a wraparound. -fail unless sysseek(BIG, 705_032_704, SEEK_SET); -print "ok 15\n"; - -my $zero; - -fail unless read(BIG, $zero, 3) == 3; -print "ok 16\n"; - -fail unless $zero eq "\0\0\0"; -print "ok 17\n"; - -explain() if $fail; - -bye(); # does the necessary cleanup - -END { - unlink "big"; # be paranoid about leaving 5 gig files lying around -} - -# eof diff --git a/contrib/perl5/t/lib/syslog.t b/contrib/perl5/t/lib/syslog.t deleted file mode 100755 index cd2fad7..0000000 --- a/contrib/perl5/t/lib/syslog.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSyslog\b/) { - print "1..0 # Skip: Sys::Syslog was not built\n"; - exit 0; - } - - require Socket; - - # This code inspired by Sys::Syslog::connect(): - require Sys::Hostname; - my ($host_uniq) = Sys::Hostname::hostname(); - my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; - - if (! defined Socket::inet_aton($host)) { - print "1..0 # Skip: Can't lookup $host\n"; - exit 0; - } -} - -BEGIN { - eval {require Sys::Syslog} or do { - if ($@ =~ /Your vendor has not/) { - print "1..0 # Skipped: missing macros\n"; - exit 0; - } - } -} - -use Sys::Syslog qw(:DEFAULT setlogsock); - -print "1..6\n"; - -if (Sys::Syslog::_PATH_LOG()) { - if (-e Sys::Syslog::_PATH_LOG()) { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; - } - else { - for (1..3) { - print - "ok $_ # skipping, file ", - Sys::Syslog::_PATH_LOG(), - " does not exist\n"; - } - } -} -else { - for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" } -} - -print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n"; -print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n"; -print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n"; diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t deleted file mode 100755 index 5ff3850..0000000 --- a/contrib/perl5/t/lib/textfill.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @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/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t deleted file mode 100755 index c6ca123..0000000 --- a/contrib/perl5/t/lib/texttabs.t +++ /dev/null @@ -1,139 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST 1 u - x -END - x -END -TEST 2 e - x -END - x -END -TEST 3 e - x - y - z -END - x - y - z -END -TEST 4 u - x - y - z -END - x - y - z -END -TEST 5 u -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 6 e -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 7 u - x -END - x -END -TEST 8 e - - - - - -END - - - - - -END -TEST 9 u - -END - -END -TEST 10 u - - - - - -END - - - - - -END -TEST 11 u -foobar IN A 140.174.82.12 - -END -foobar IN A 140.174.82.12 - -END -DONE - -$| = 1; - -print "1..".scalar(@tests/2)."\n"; - -use Text::Tabs; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); - - $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; - - if ($2 eq 'e') { - $f = \&expand; - $fn = 'expand'; - } else { - $f = \&unexpand; - $fn = 'unexpand'; - } - - my $back = &$f($in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\$\n------------ $fn -----------\n"; - print $back; - print "\$\n------------ expected ---------\n"; - print $out; - print "\$\n-------------------------------\n"; - $Text::Tabs::debug = 1; - my $back = &$f($in); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t deleted file mode 100755 index fee6ce0..0000000 --- a/contrib/perl5/t/lib/textwrap.t +++ /dev/null @@ -1,209 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@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. - -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. - -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. - -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 -TEST10 -my mother once said -"never eat paste my darling" -would that I heeded -END - my mother once said - "never eat paste my darling" - would that I heeded -END -TEST11 -This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn -END - This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr - ogram_does_not_crash_and_burn -END -TEST12 -This - -Has - -Blank - -Lines - -END - This - - Has - - Blank - - Lines - -END -DONE - - -$| = 1; - -print "1..", 1 +@tests, "\n"; - -use Text::Wrap; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; - -@st = @tests; -while (@st) { - my $in = shift(@st); - my $out = shift(@st); - - $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++; - -} - -@st = @tests; -while(@st) { - my $in = shift(@st); - my $out = shift(@st); - - $in =~ s/^TEST(\d+)?\n//; - - my @in = split("\n", $in, -1); - @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); - - my $back = wrap(' ', ' ', @in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input2 ------------\n"; - print $in; - print "\n------------ output2 -----------\n"; - print $back; - print "\n------------ expected2 ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - wrap(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} - -$Text::Wrap::huge = 'overflow'; - -my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; -my $w = wrap('zzz','yyy',$tw); -print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); -$tn++; - diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t deleted file mode 100755 index 680e1af..0000000 --- a/contrib/perl5/t/lib/thr5005.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (! $Config{'use5005threads'}) { - print "1..0 # Skip: not use5005threads\n"; - exit 0; - } - - # XXX known trouble with global destruction - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} -$| = 1; -print "1..22\n"; -use Thread 'yield'; -print "ok 1\n"; - -sub content -{ - print shift; - return shift; -} - -# create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); -print $t->join; - -# check that lock works ... -{lock $foo; - $t = new Thread sub { lock $foo; print "ok 5\n" }; - print "ok 4\n"; -} -$t->join; - -sub dorecurse -{ - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&dorecurse, @_); - $ret->join; - } -} - -$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; -$t->join; - -# test that sleep lets other thread run -$t = new Thread \&dorecurse,"ok 11\n"; -sleep 6; -print "ok 12\n"; -$t->join; - -sub islocked : locked { - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&islocked, shift); - } - $ret; -} - -$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); -$t->join->join; - -{ - package Loch::Ness; - sub new { bless [], shift } - sub monster : locked : method { - my($s, $m) = @_; - print "ok $m\n"; - } - sub gollum { &monster } -} -Loch::Ness->monster(15); -Loch::Ness->new->monster(16); -Loch::Ness->gollum(17); -Loch::Ness->new->gollum(18); - -my $short = "This is a long string that goes on and on."; -my $shorte = " a long string that goes on and on."; -my $long = "This is short."; -my $longe = " short."; -my $thr1 = new Thread \&threaded, $short, $shorte, "19"; -my $thr2 = new Thread \&threaded, $long, $longe, "20"; -my $thr3 = new Thread \&testsprintf, "21"; - -sub testsprintf { - my $testno = shift; - # this may coredump if thread vars are not properly initialised - my $same = sprintf "%.0f", $testno; - if ($testno eq $same) { - print "ok $testno\n"; - } else { - print "not ok $testno\t# '$testno' ne '$same'\n"; - } -} - -sub threaded { - my ($string, $string_end, $testno) = @_; - - # Do the match, saving the output in appropriate variables - $string =~ /(.*)(is)(.*)/; - # Yield control, allowing the other thread to fill in the match variables - yield(); - # Examine the match variable contents; on broken perls this fails - if ($3 eq $string_end) { - print "ok $testno\n"; - } - else { - warn <<EOT; - -# -# This is a KNOWN FAILURE, and one of the reasons why threading -# is still an experimental feature. It is here to stop people -# from deploying threads in production. ;-) -# -EOT - print "not ok $testno # other thread filled in match variables\n"; - } -} -$thr1->join; -$thr2->join; -$thr3->join; -print "ok 22\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t deleted file mode 100755 index b19aa0d..0000000 --- a/contrib/perl5/t/lib/tie-push.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -{ - package Basic; - use Tie::Array; - @ISA = qw(Tie::Array); - - sub TIEARRAY { return bless [], shift } - sub FETCH { $_[0]->[$_[1]] } - sub STORE { $_[0]->[$_[1]] = $_[2] } - sub FETCHSIZE { scalar(@{$_[0]}) } - sub STORESIZE { $#{$_[0]} = $_[1]-1 } -} - -tie @x,Basic; -tie @get,Basic; -tie @got,Basic; -tie @tests,Basic; -require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-refhash.t b/contrib/perl5/t/lib/tie-refhash.t deleted file mode 100755 index d80b2e1..0000000 --- a/contrib/perl5/t/lib/tie-refhash.t +++ /dev/null @@ -1,305 +0,0 @@ -#!/usr/bin/perl -w -# -# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. -# -# The testing is in two parts: first, run lots of tests on both a tied -# hash and an ordinary un-tied hash, and check they give the same -# answer. Then there are tests for those cases where the tied hashes -# should behave differently to normal hashes, that is, when using -# references as keys. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use strict; -use Tie::RefHash; -use Data::Dumper; -my $numtests = 34; -my $currtest = 1; -print "1..$numtests\n"; - -my $ref = []; my $ref1 = []; - -# Test standard hash functionality, by performing the same operations -# on a tied hash and on a normal hash, and checking that the results -# are the same. This does of course assume that Perl hashes are not -# buggy :-) -# -my @tests = standard_hash_tests(); - -my @ordinary_results = runtests(\@tests, undef); -foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { - my @tied_results = runtests(\@tests, $class); - my $all_ok = 1; - - die if @ordinary_results != @tied_results; - foreach my $i (0 .. $#ordinary_results) { - my ($or, $ow, $oe) = @{$ordinary_results[$i]}; - my ($tr, $tw, $te) = @{$tied_results[$i]}; - - my $ok = 1; - local $^W = 0; - $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); - $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); - $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); - - if (not $ok) { - print STDERR - "failed for $class: $tests[$i]\n", - "ordinary hash gave:\n", - defined $or ? "\tresult: $or\n" : "\tundef result\n", - defined $ow ? "\twarning: $ow\n" : "\tno warning\n", - defined $oe ? "\texception: $oe\n" : "\tno exception\n", - "tied $class hash gave:\n", - defined $tr ? "\tresult: $tr\n" : "\tundef result\n", - defined $tw ? "\twarning: $tw\n" : "\tno warning\n", - defined $te ? "\texception: $te\n" : "\tno exception\n", - "\n"; - $all_ok = 0; - } - } - test($all_ok); -} - -# Now test Tie::RefHash's special powers -my (%h, $h); -$h = eval { tie %h, 'Tie::RefHash' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); -$h{$ref} = 'cholet'; -test($h{$ref} eq 'cholet'); -test(exists $h{$ref}); -test((keys %h) == 1); -test(ref((keys %h)[0]) eq 'ARRAY'); -test((keys %h)[0] eq $ref); -test((values %h) == 1); -test((values %h)[0] eq 'cholet'); -my $count = 0; -while (my ($k, $v) = each %h) { - if ($count++ == 0) { - test(ref($k) eq 'ARRAY'); - test($k eq $ref); - } -} -test($count == 1); -delete $h{$ref}; -test(not defined $h{$ref}); -test(not exists($h{$ref})); -test((keys %h) == 0); -test((values %h) == 0); -undef $h; -untie %h; - -# And now Tie::RefHash::Nestable's differences from Tie::RefHash. -$h = eval { tie %h, 'Tie::RefHash::Nestable' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash::Nestable'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); -$h{$ref}->{$ref1} = 'bungo'; -test($h{$ref}->{$ref1} eq 'bungo'); - -# Test that the nested hash is also tied (for current implementation) -test(defined(tied(%{$h{$ref}})) - and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); - -test((keys %h) == 1); -test((keys %h)[0] eq $ref); -test((keys %{$h{$ref}}) == 1); -test((keys %{$h{$ref}})[0] eq $ref1); - - -die "expected to run $numtests tests, but ran ", $currtest - 1 - if $currtest - 1 != $numtests; - -@tests = (); -undef $ref; -undef $ref1; - -exit(); - - -# Print 'ok X' if true, 'not ok X' if false -# Uses global $currtest. -# -sub test { - my $t = shift; - print 'not ' if not $t; - print 'ok ', $currtest++, "\n"; -} - - -# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. -sub dumped { - my $s = shift; - my $d = Dumper($s); - $d =~ s/^\$VAR1 =\s*//; - $d =~ s/;$//; - chomp $d; - return $d; -} - -# Crudely dump a hash into a canonical string representation (because -# hash keys can appear in any order, Data::Dumper may give different -# strings for the same hash). -# -sub dumph { - my $h = shift; - my $r = ''; - foreach (sort keys %$h) { - $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; - } - return $r; -} - -# Run the tests and give results. -# -# Parameters: reference to list of tests to run -# name of class to use for tied hash, or undef if not tied -# -# Returns: list of [R, W, E] tuples, one for each test. -# R is the return value from running the test, W any warnings it gave, -# and E any exception raised with 'die'. E and W will be tidied up a -# little to remove irrelevant details like line numbers :-) -# -# Will also run a few of its own 'ok N' tests. -# -sub runtests { - my ($tests, $class) = @_; - my @r; - - my (%h, $h); - if (defined $class) { - $h = eval { tie %h, $class }; - warn $@ if $@; - test(not $@); - test(ref($h) eq $class); - test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); - } - - foreach (@$tests) { - my ($result, $warning, $exception); - local $SIG{__WARN__} = sub { $warning .= $_[0] }; - $result = scalar(eval $_); - if ($@) - { - die "$@:$_" unless defined $class; - $exception = $@; - } - - foreach ($warning, $exception) { - next if not defined; - s/ at .+ line \d+\.$//mg; - s/ at .+ line \d+, at .*//mg; - s/ at .+ line \d+, near .*//mg; - } - - my (@warnings, %seen); - foreach (split /\n/, $warning) { - push @warnings, $_ unless $seen{$_}++; - } - $warning = join("\n", @warnings); - - push @r, [ $result, $warning, $exception ]; - } - - return @r; -} - - -# Things that should work just the same for an ordinary hash and a -# Tie::RefHash. -# -# Each test is a code string to be eval'd, it should do something with -# %h and give a scalar return value. The global $ref and $ref1 may -# also be used. -# -# One thing we don't test is that the ordering from 'keys', 'values' -# and 'each' is the same. You can't reasonably expect that. -# -sub standard_hash_tests { - my @r; - - # Library of standard tests on keys, values and each - my $STD_TESTS = <<'END' - join $;, sort keys %h; - join $;, sort values %h; - { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } - { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) } -END - ; - - # Tests on the existence of the element 'foo' - my $FOO_TESTS = <<'END' - defined $h{foo}; - exists $h{foo}; - $h{foo}; -END - ; - - # Test storing and deleting 'foo' - push @r, split /\n/, <<"END" - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = undef; - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = 'hello'; - $STD_TESTS; - $FOO_TESTS; - delete \$h{foo}; - $STD_TESTS; - $FOO_TESTS; -END - ; - - # Test storing and removing under ordinary keys - my @things = ('boink', 0, 1, '', undef); - foreach my $key (map { dumped($_) } @things) { - foreach my $value ((map { dumped($_) } @things), '$ref') { - push @r, split /\n/, <<"END" - \$h{$key} = $value; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; - delete \$h{$key}; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; -END - ; - } - } - - # Test hash slices - my @slicetests; - @slicetests = split /\n/, <<'END' - @h{'b'} = (); - @h{'c'} = ('d'); - @h{'e'} = ('f', 'g'); - @h{'h', 'i'} = (); - @h{'j', 'k'} = ('l'); - @h{'m', 'n'} = ('o', 'p'); - @h{'q', 'r'} = ('s', 't', 'u'); -END - ; - my @aaa = @slicetests; - foreach (@slicetests) { - push @r, $_; - push @r, split(/\n/, $STD_TESTS); - } - - # Test CLEAR - push @r, '%h = ();', split(/\n/, $STD_TESTS); - - return @r; -} - diff --git a/contrib/perl5/t/lib/tie-splice.t b/contrib/perl5/t/lib/tie-splice.t deleted file mode 100755 index d7ea6cc..0000000 --- a/contrib/perl5/t/lib/tie-splice.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -# bug id 20001020.002 -# -dlc 20001021 - -use Tie::Array; -tie @a,Tie::StdArray; -undef *Tie::StdArray::SPLICE; -require "op/splice.t" - -# Pre-fix, this failed tests 6-9 diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t deleted file mode 100755 index c4ae071..0000000 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @foo,Tie::StdArray; -tie @ary,Tie::StdArray; -tie @bar,Tie::StdArray; -require "op/array.t" diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t deleted file mode 100755 index f03f5d9..0000000 --- a/contrib/perl5/t/lib/tie-stdhandle.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @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") && open($f, "+<", "afile"); -print "ok 1\n"; -print "$!\nnot " unless binmode($f); -print "ok 2\n"; -print "not " unless -f "afile"; -print "ok 3\n"; -print "not " unless print $f "SomeData\n"; -print "ok 4\n"; -print "not " unless tell($f) == 9; -print "ok 5\n"; -print "not " unless printf $f "Some %d value\n",1234; -print "ok 6\n"; -print "not " unless seek($f,0,0); -print "ok 7\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 8\n"; -print "not " if eof($f); -print "ok 9\n"; -read($f,($b=''),4); -print "'$b' not " unless $b eq 'Some'; -print "ok 10\n"; -print "not " unless getc($f) eq ' '; -print "ok 11\n"; -$b = <$f>; -print "not " unless eof($f); -print "ok 12\n"; -print "not " unless close($f); -print "ok 13\n"; -unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t deleted file mode 100755 index 31af30c..0000000 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @x,Tie::StdArray; -require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-substrhash.t b/contrib/perl5/t/lib/tie-substrhash.t deleted file mode 100755 index 8256db7..0000000 --- a/contrib/perl5/t/lib/tie-substrhash.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -print "1..20\n"; - -use strict; - -require Tie::SubstrHash; - -my %a; - -tie %a, 'Tie::SubstrHash', 3, 3, 3; - -$a{abc} = 123; -$a{bcd} = 234; - -print "not " unless $a{abc} == 123; -print "ok 1\n"; - -print "not " unless keys %a == 2; -print "ok 2\n"; - -delete $a{abc}; - -print "not " unless $a{bcd} == 234; -print "ok 3\n"; - -print "not " unless (values %a)[0] == 234; -print "ok 4\n"; - -eval { $a{abcd} = 123 }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 5\n"; - -eval { $a{abc} = 1234 }; -print "not " unless $@ =~ /Value "1234" is not 3 characters long/; -print "ok 6\n"; - -eval { $a = $a{abcd}; $a++ }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 7\n"; - -@a{qw(abc cde)} = qw(123 345); - -print "not " unless $a{cde} == 345; -print "ok 8\n"; - -eval { $a{def} = 456 }; -print "not " unless $@ =~ /Table is full \(3 elements\)/; -print "ok 9\n"; - -%a = (); - -print "not " unless keys %a == 0; -print "ok 10\n"; - -# Tests 11..16 by Linc Madison. - -my $hashsize = 119; # arbitrary values from my data -my %test; -tie %test, "Tie::SubstrHash", 13, 86, $hashsize; - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; # fix to uniform 6-digit numbers - my $key2 = "abcdefg$key1"; - $test{$key2} = ("abcdefgh" x 10) . "$key1"; -} - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; - my $key2 = "abcdefg$key1"; - unless ($test{$key2}) { - print "not "; - last; - } -} -print "ok 11\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1) == 2; -print "ok 12\n"; - -print "not " unless Tie::SubstrHash::findgteprime(2) == 2; -print "ok 13\n"; - -print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; -print "ok 14\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13) == 13; -print "ok 15\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; -print "ok 16\n"; - -print "not " unless Tie::SubstrHash::findgteprime(114) == 127; -print "ok 17\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; -print "ok 18\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; -print "ok 19\n"; - -print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; -print "ok 20\n"; - diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t deleted file mode 100755 index 100e076..0000000 --- a/contrib/perl5/t/lib/timelocal.t +++ /dev/null @@ -1,90 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Time::Local; - -# Set up time values to test -@time = - ( - #year,mon,day,hour,min,sec - [1970, 1, 2, 00, 00, 00], - [1980, 2, 28, 12, 00, 00], - [1980, 2, 29, 12, 00, 00], - [1999, 12, 31, 23, 59, 59], - [2000, 1, 1, 00, 00, 00], - [2010, 10, 12, 14, 13, 12], - ); - -# use vmsish 'time' makes for oddness around the Unix epoch -if ($^O eq 'VMS') { $time[0][2]++ } - -print "1..", @time * 2 + 5, "\n"; - -$count = 1; -for (@time) { - my($year, $mon, $mday, $hour, $min, $sec) = @$_; - $year -= 1900; - $mon --; - my $time = timelocal($sec,$min,$hour,$mday,$mon,$year); - # print scalar(localtime($time)), "\n"; - my($s,$m,$h,$D,$M,$Y) = localtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; - - # Test gmtime function - $time = timegm($sec,$min,$hour,$mday,$mon,$year); - ($s,$m,$h,$D,$M,$Y) = gmtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; -} - -#print "Testing that the differences between a few dates makes sence...\n"; - -timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600 - or print "not "; -print "ok ", $count++, "\n"; - -timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - -# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days) -timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - - -#print "Testing timelocal.pl module too...\n"; -package test; -require 'timelocal.pl'; -timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not "; -print "ok ", $main::count++, "\n"; - -timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not "; -print "ok ", $main::count++, "\n"; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t deleted file mode 100755 index 6949622..0000000 --- a/contrib/perl5/t/lib/trig.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./perl - -# -# Regression tests for the Math::Trig package -# -# The tests are quite modest as the Math::Complex tests exercise -# these quite vigorously. -# -# -- Jarkko Hietaniemi, April 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Trig; - -use strict; - -use vars qw($x $y $z); - -my $eps = 1e-11; - -if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. - $eps = 1e-10; -} - -sub near ($$;$) { - my $e = defined $_[2] ? $_[2] : $eps; - $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; -} - -print "1..23\n"; - -$x = 0.9; -print 'not ' unless (near(tan($x), sin($x) / cos($x))); -print "ok 1\n"; - -print 'not ' unless (near(sinh(2), 3.62686040784702)); -print "ok 2\n"; - -print 'not ' unless (near(acsch(0.1), 2.99822295029797)); -print "ok 3\n"; - -$x = asin(2); -print 'not ' unless (ref $x eq 'Math::Complex'); -print "ok 4\n"; - -# avoid using Math::Complex here -$x =~ /^([^-]+)(-[^i]+)i$/; -($y, $z) = ($1, $2); -print 'not ' unless (near($y, 1.5707963267949) and - near($z, -1.31695789692482)); -print "ok 5\n"; - -print 'not ' unless (near(deg2rad(90), pi/2)); -print "ok 6\n"; - -print 'not ' unless (near(rad2deg(pi), 180)); -print "ok 7\n"; - -use Math::Trig ':radial'; - -{ - my ($r,$t,$z) = cartesian_to_cylindrical(1,1,1); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 1)); - print "ok 8\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 9\n"; - - ($r,$t,$z) = cartesian_to_cylindrical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 0)); - print "ok 10\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 11\n"; -} - -{ - my ($r,$t,$f) = cartesian_to_spherical(1,1,1); - - print 'not ' unless (near($r, sqrt(3))) and - (near($t, deg2rad(45))) and - (near($f, atan2(sqrt(2), 1))); - print "ok 12\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 13\n"; - - ($r,$t,$f) = cartesian_to_spherical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($f, deg2rad(90))); - print "ok 14\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 15\n"; -} - -{ - my ($r,$t,$z) = cylindrical_to_spherical(spherical_to_cylindrical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 16\n"; - - ($r,$t,$z) = spherical_to_cylindrical(cylindrical_to_spherical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 17\n"; -} - -{ - use Math::Trig 'great_circle_distance'; - - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; - - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; - - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - - my $km = great_circle_distance(@L, @T, 6378); - - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; -} - -{ - my $R2D = 57.295779513082320876798154814169; - - sub frac { $_[0] - int($_[0]) } - - my $lotta_radians = deg2rad(1E+20, 1); - print "not " unless near($lotta_radians, 1E+20/$R2D); - print "ok 21\n"; - - my $negat_degrees = rad2deg(-1E20, 1); - print "not " unless near($negat_degrees, -1E+20*$R2D); - print "ok 22\n"; - - my $posit_degrees = rad2deg(-10000, 1); - print "not " unless near($posit_degrees, -10000*$R2D); - print "ok 23\n"; -} - -# eof diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t deleted file mode 100755 index 88fbc55..0000000 --- a/contrib/perl5/t/op/64bitint.t +++ /dev/null @@ -1,297 +0,0 @@ -#./perl - -BEGIN { - eval { my $q = pack "q", 0 }; - if ($@) { - print "1..0\n# Skip: no 64-bit types\n"; - exit(0); - } - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# This could use many more tests. - -# so that using > 0xfffffff constants and -# 32+ bit integers don't cause noise -no warnings qw(overflow portable); - -print "1..55\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"; - -if ($^O ne 'unicos') { - $x = $q * 1234567; - print "not " unless $x == 15241567763770867 && $x > $f; - print "ok 23\n"; - - $x /= 1234567; - print "not " unless $x == $q && $x > $f; - print "ok 24\n"; - - $x = 98765432109 % 12345678901; - print "not " unless $x == 901; - print "ok 25\n"; - - # The following 12 tests adapted from op/inc. - - $a = 9223372036854775807; - $c = $a++; - print "not " unless $a == 9223372036854775808; - print "ok 26\n"; - - $a = 9223372036854775807; - $c = ++$a; - print "not " - unless $a == 9223372036854775808 && $c == $a; - print "ok 27\n"; - - $a = 9223372036854775807; - $c = $a + 1; - print "not " - unless $a == 9223372036854775807 && $c == 9223372036854775808; - print "ok 28\n"; - - $a = -9223372036854775808; - $c = $a--; - print "not " - unless $a == -9223372036854775809 && $c == -9223372036854775808; - print "ok 29\n"; - - $a = -9223372036854775808; - $c = --$a; - print "not " - unless $a == -9223372036854775809 && $c == $a; - print "ok 30\n"; - - $a = -9223372036854775808; - $c = $a - 1; - print "not " - unless $a == -9223372036854775808 && $c == -9223372036854775809; - print "ok 31\n"; - - $a = 9223372036854775808; - $a = -$a; - $c = $a--; - print "not " - unless $a == -9223372036854775809 && $c == -9223372036854775808; - print "ok 32\n"; - - $a = 9223372036854775808; - $a = -$a; - $c = --$a; - print "not " - unless $a == -9223372036854775809 && $c == $a; - print "ok 33\n"; - - $a = 9223372036854775808; - $a = -$a; - $c = $a - 1; - print "not " - unless $a == -9223372036854775808 && $c == -9223372036854775809; - print "ok 34\n"; - - $a = 9223372036854775808; - $b = -$a; - $c = $b--; - print "not " - unless $b == -$a-1 && $c == -$a; - print "ok 35\n"; - - $a = 9223372036854775808; - $b = -$a; - $c = --$b; - print "not " - unless $b == -$a-1 && $c == $b; - print "ok 36\n"; - - $a = 9223372036854775808; - $b = -$a; - $b = $b - 1; - print "not " - unless $b == -(++$a); - print "ok 37\n"; - -} else { - # Unicos has imprecise doubles (14 decimal digits or so), - # especially if operating near the UV/IV limits the low-order bits - # become mangled even by simple arithmetic operations. - for (23..37) { - print "ok $_ # skipped: too imprecise numbers\n"; - } -} - - -$x = ''; -print "not " unless (vec($x, 1, 64) = $q) == $q; -print "ok 38\n"; - -print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f; -print "ok 39\n"; - -print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0; -print "ok 40\n"; - - -print "not " unless ~0 == 0xffffffffffffffff; -print "ok 41\n"; - -print "not " unless (0xffffffff<<32) == 0xffffffff00000000; -print "ok 42\n"; - -print "not " unless ((0xffffffff)<<32)>>32 == 0xffffffff; -print "ok 43\n"; - -print "not " unless 1<<63 == 0x8000000000000000; -print "ok 44\n"; - -print "not " unless (sprintf "%#Vx", 1<<63) eq '0x8000000000000000'; -print "ok 45\n"; - -print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; -print "ok 46\n"; - -print "not " - unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; -print "ok 47\n"; - -print "not " - unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; -print "ok 48\n"; - - -print "not " - unless (sprintf "%b", ~0) eq - '1111111111111111111111111111111111111111111111111111111111111111'; -print "ok 49\n"; - -print "not " - unless (sprintf "%64b", ~0) eq - '1111111111111111111111111111111111111111111111111111111111111111'; -print "ok 50\n"; - -print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; -print "ok 51\n"; - -print "not " unless (sprintf "%u", ~0) eq '18446744073709551615'; -print "ok 52\n"; - -# If the 53..55 fail you have problems in the parser's string->int conversion, -# see toke.c:scan_num(). - -$q = -9223372036854775808; -print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808"; -print "ok 53\n"; - -$q = 9223372036854775807; -print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807"; -print "ok 54\n"; - -$q = 18446744073709551615; -print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; -print "ok 55\n"; - -# eof diff --git a/contrib/perl5/t/op/anonsub.t b/contrib/perl5/t/op/anonsub.t deleted file mode 100755 index 17889d9..0000000 --- a/contrib/perl5/t/op/anonsub.t +++ /dev/null @@ -1,93 +0,0 @@ -#!./perl - -chdir 't' if -d 't'; -@INC = '../lib'; -$Is_VMS = $^O eq 'VMS'; -$Is_MSWin32 = $^O eq 'MSWin32'; -$ENV{PERL5LIB} = "../lib" unless $Is_VMS; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "asubtmp000"; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } - -for (@prgs){ - my $switch = ""; - if (s/^\s*(-\w+)//){ - $switch = $1; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, ">$tmpfile"; - print TEST "$prog\n"; - close TEST; - my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $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/runltmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $expected =~ s/\n+$//; - if ($results ne $expected) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ -sub X { - my $n = "ok 1\n"; - sub { print $n }; -} -my $x = X(); -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X { - my $n = "ok 1\n"; - sub { - my $dummy = $n; # eval can't close on $n without internal reference - eval 'print $n'; - die $@ if $@; - }; -} -my $x = X(); -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X { - my $n = "ok 1\n"; - eval 'sub { print $n }'; -} -my $x = X(); -die $@ if $@; -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X; -sub X { - my $n = "ok 1\n"; - eval 'sub Y { my $p = shift; $p->() }'; - die $@ if $@; - Y(sub { print $n }); -} -X(); -EXPECT -ok 1 diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t deleted file mode 100755 index 5aa4bf9..0000000 --- a/contrib/perl5/t/op/append.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ - -print "1..13\n"; - -$a = 'ab' . 'c'; # compile time -$b = 'def'; - -$c = $a . $b; -print "#1\t:$c: eq :abcdef:\n"; -if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";} - -$c .= 'xyz'; -print "#2\t:$c: eq :abcdefxyz:\n"; -if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = $a; -$_ .= $b; -print "#3\t:$_: eq :abcdef:\n"; -if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} - -# test that when right argument of concat is UTF8, and is the same -# variable as the target, and the left argument is not UTF8, it no -# longer frees the wrong string. -{ - sub r2 { - my $string = ''; - $string .= pack("U0a*", 'mnopqrstuvwx'); - $string = "abcdefghijkl$string"; - } - - r2() and print "ok $_\n" for qw/ 4 5 /; -} - -# test that nul bytes get copied -{ -# Character 'b' occurs at codepoint 130 decimal or \202 octal -# under an EBCDIC coded character set. -# my($a, $ab) = ("a", "a\000b"); - my($a, $ab) = ("\141", "\141\000\142"); - my($u, $ub) = map pack("U0a*", $_), $a, $ab; - my $t1 = $a; $t1 .= $ab; - print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n"; - my $t2 = $a; $t2 .= $ub; - print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n"; - my $t3 = $u; $t3 .= $ab; - print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n"; - my $t4 = $u; $t4 .= $ub; - print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n"; - my $t5 = $a; $t5 = $ab . $t5; - print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n"; - my $t6 = $a; $t6 = $ub . $t6; - print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n"; - my $t7 = $u; $t7 = $ab . $t7; - print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n"; - my $t8 = $u; $t8 = $ub . $t8; - print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n"; -} diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t deleted file mode 100755 index ce2c398..0000000 --- a/contrib/perl5/t/op/args.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -print "1..9\n"; - -# test various operations on @_ - -my $ord = 0; -sub new1 { bless \@_ } -{ - my $x = new1("x"); - my $y = new1("y"); - ++$ord; - print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; - print "ok $ord\n"; - ++$ord; - print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; - print "ok $ord\n"; -} - -sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } -{ - my $x = new2("x"); - my $y = new2("y"); - ++$ord; - print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; - print "ok $ord\n"; - ++$ord; - print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; - print "ok $ord\n"; -} - -sub new3 { goto &new1 } -{ - my $x = new3("x"); - my $y = new3("y"); - ++$ord; - print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; - print "ok $ord\n"; - ++$ord; - print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; - print "ok $ord\n"; -} - -sub new4 { goto &new2 } -{ - my $x = new4("x"); - my $y = new4("y"); - ++$ord; - print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; - print "ok $ord\n"; - ++$ord; - print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; - print "ok $ord\n"; -} - -# see if POPSUB gets to see the right pad across a dounwind() with -# a reified @_ - -sub methimpl { - my $refarg = \@_; - die( "got: @_\n" ); -} - -sub method { - &methimpl; -} - -sub try { - eval { method('foo', 'bar'); }; - print "# $@" if $@; -} - -for (1..5) { try() } -++$ord; -print "ok $ord\n"; diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t deleted file mode 100755 index 5b04f93..0000000 --- a/contrib/perl5/t/op/arith.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl - -print "1..12\n"; - -sub try ($$) { - print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; -} - -try 1, 13 % 4 == 1; -try 2, -13 % 4 == 3; -try 3, 13 % -4 == -3; -try 4, -13 % -4 == -1; - -my $limit = 1e6; - -# Division (and modulo) of floating point numbers -# seem to be rather sloppy in Cray. -$limit = 1e8 if $^O eq 'unicos'; - -try 5, abs( 13e21 % 4e21 - 1e21) < $limit; -try 6, abs(-13e21 % 4e21 - 3e21) < $limit; -try 7, abs( 13e21 % -4e21 - -3e21) < $limit; -try 8, abs(-13e21 % -4e21 - -1e21) < $limit; - -# UVs should behave properly - -try 9, 4063328477 % 65535 == 27407; -try 10, 4063328477 % 4063328476 == 1; -try 11, 4063328477 % 2031664238 == 1; -try 12, 2031664238 % 4063328477 == 2031664238; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t deleted file mode 100755 index 7cc84e3..0000000 --- a/contrib/perl5/t/op/array.t +++ /dev/null @@ -1,231 +0,0 @@ -#!./perl - -print "1..70\n"; - -# -# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them -# - -@ary = (1,2,3,4,5); -if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";} - -$tmp = $ary[$#ary]; --$#ary; -if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";} -if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";} -if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";} - -$[ = 1; -@ary = (1,2,3,4,5); -if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";} - -$tmp = $ary[$#ary]; --$#ary; -if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";} -if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";} -if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";} - -if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";} - -$#ary += 1; # see if element 5 gone for good -if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} -if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";} - -$[ = 0; -@foo = (); -$r = join(',', $#foo, @foo); -if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";} -$foo[0] = '0'; -$r = join(',', $#foo, @foo); -if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";} -$foo[2] = '2'; -$r = join(',', $#foo, @foo); -if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";} -@bar = (); -$bar[0] = '0'; -$bar[1] = '1'; -$r = join(',', $#bar, @bar); -if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";} -@bar = (); -$r = join(',', $#bar, @bar); -if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";} -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";} -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";} -reset 'b'; -@bar = (); -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";} -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";} - -$foo = 'now is the time'; -if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) { - if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') { - print "ok 21\n"; - } - else { - print "not ok 21\n"; - } -} -else { - print "not ok 21\n"; -} - -$foo = 'lskjdf'; -if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) { - print "not ok 22 $cnt $F1:$F2:$Etc\n"; -} -else { - print "ok 22\n"; -} - -%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); -%bar = %foo; -print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n"; -%bar = (); -print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n"; -(%bar,$a,$b) = (%foo,'how','now'); -print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n"; -print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n"; -@bar{keys %foo} = values %foo; -print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n"; -print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n"; - -@foo = grep(/e/,split(' ','now is the time for all good men to come to')); -print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n"; - -@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); -print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n"; - -$foo = join('',('a','b','c','d','e','f')[0..5]); -print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n"; - -$foo = join('',('a','b','c','d','e','f')[0..1]); -print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n"; - -$foo = join('',('a','b','c','d','e','f')[6]); -print $foo eq '' ? "ok 33\n" : "not ok 33\n"; - -@foo = ('a','b','c','d','e','f')[0,2,4]; -@bar = ('a','b','c','d','e','f')[1,3,5]; -$foo = join('',(@foo,@bar)[0..5]); -print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n"; - -$foo = ('a','b','c','d','e','f')[0,2,4]; -print $foo eq 'e' ? "ok 35\n" : "not ok 35\n"; - -$foo = ('a','b','c','d','e','f')[1]; -print $foo eq 'b' ? "ok 36\n" : "not ok 36\n"; - -@foo = ( 'foo', 'bar', 'burbl'); -push(foo, 'blah'); -print $#foo == 3 ? "ok 37\n" : "not ok 37\n"; - -# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) - -$test = 37; -sub t { ++$test; print "not " unless $_[0]; print "ok $test\n"; } - -@foo = @foo; -t("@foo" eq "foo bar burbl blah"); # 38 - -(undef,@foo) = @foo; -t("@foo" eq "bar burbl blah"); # 39 - -@foo = ('XXX',@foo, 'YYY'); -t("@foo" eq "XXX bar burbl blah YYY"); # 40 - -@foo = @foo = qw(foo b\a\r bu\\rbl blah); -t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 - -@bar = @foo = qw(foo bar); # 42 -t("@foo" eq "foo bar"); -t("@bar" eq "foo bar"); # 43 - -# try the same with local -# XXX tie-stdarray fails the tests involving local, so we use -# different variable names to escape the 'tie' - -@bee = ( 'foo', 'bar', 'burbl', 'blah'); -{ - - local @bee = @bee; - t("@bee" eq "foo bar burbl blah"); # 44 - { - local (undef,@bee) = @bee; - t("@bee" eq "bar burbl blah"); # 45 - { - local @bee = ('XXX',@bee,'YYY'); - t("@bee" eq "XXX bar burbl blah YYY"); # 46 - { - local @bee = local(@bee) = qw(foo bar burbl blah); - t("@bee" eq "foo bar burbl blah"); # 47 - { - local (@bim) = local(@bee) = qw(foo bar); - t("@bee" eq "foo bar"); # 48 - t("@bim" eq "foo bar"); # 49 - } - t("@bee" eq "foo bar burbl blah"); # 50 - } - t("@bee" eq "XXX bar burbl blah YYY"); # 51 - } - t("@bee" eq "bar burbl blah"); # 52 - } - t("@bee" eq "foo bar burbl blah"); # 53 -} - -# try the same with my -{ - - my @bee = @bee; - t("@bee" eq "foo bar burbl blah"); # 54 - { - my (undef,@bee) = @bee; - t("@bee" eq "bar burbl blah"); # 55 - { - my @bee = ('XXX',@bee,'YYY'); - t("@bee" eq "XXX bar burbl blah YYY"); # 56 - { - my @bee = my @bee = qw(foo bar burbl blah); - t("@bee" eq "foo bar burbl blah"); # 57 - { - my (@bim) = my(@bee) = qw(foo bar); - t("@bee" eq "foo bar"); # 58 - t("@bim" eq "foo bar"); # 59 - } - t("@bee" eq "foo bar burbl blah"); # 60 - } - t("@bee" eq "XXX bar burbl blah YYY"); # 61 - } - t("@bee" eq "bar burbl blah"); # 62 - } - 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'); - -# qw() is no more a runtime split, it's compiletime. -print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; -print "ok 66\n"; - -@ary = (12,23,34,45,56); - -print "not " unless shift(@ary) == 12; -print "ok 67\n"; - -print "not " unless pop(@ary) == 56; -print "ok 68\n"; - -print "not " unless push(@ary,56) == 4; -print "ok 69\n"; - -print "not " unless unshift(@ary,12) == 5; -print "ok 70\n"; diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t deleted file mode 100755 index aff433c..0000000 --- a/contrib/perl5/t/op/assignwarn.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -# -# Verify which OP= operators warn if their targets are undefined. -# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> -# -- Robin Barker <rmb@cise.npl.co.uk> -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -use warnings; - -my $warn = ""; -$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; - -sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } - -sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } - -print "1..32\n"; - -{ my $x; $x ++; ok 1, ! uninitialized; } -{ my $x; $x --; ok 2, ! uninitialized; } -{ my $x; ++ $x; ok 3, ! uninitialized; } -{ my $x; -- $x; ok 4, ! uninitialized; } - -{ my $x; $x **= 1; ok 5, uninitialized; } - -{ my $x; $x += 1; ok 6, ! uninitialized; } -{ my $x; $x -= 1; ok 7, ! uninitialized; } - -{ my $x; $x .= 1; ok 8, ! uninitialized; } - -{ my $x; $x *= 1; ok 9, uninitialized; } -{ my $x; $x /= 1; ok 10, uninitialized; } -{ my $x; $x %= 1; ok 11, uninitialized; } - -{ my $x; $x x= 1; ok 12, uninitialized; } - -{ my $x; $x &= 1; ok 13, uninitialized; } -{ my $x; $x |= 1; ok 14, ! uninitialized; } -{ my $x; $x ^= 1; ok 15, ! uninitialized; } - -{ my $x; $x &&= 1; ok 16, ! uninitialized; } -{ my $x; $x ||= 1; ok 17, ! uninitialized; } - -{ my $x; $x <<= 1; ok 18, uninitialized; } -{ my $x; $x >>= 1; ok 19, uninitialized; } - -{ my $x; $x &= "x"; ok 20, uninitialized; } -{ my $x; $x |= "x"; ok 21, ! uninitialized; } -{ my $x; $x ^= "x"; ok 22, ! uninitialized; } - -{ use integer; my $x; $x += 1; ok 23, ! uninitialized; } -{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; } - -{ use integer; my $x; $x *= 1; ok 25, uninitialized; } -{ use integer; my $x; $x /= 1; ok 26, uninitialized; } -{ use integer; my $x; $x %= 1; ok 27, uninitialized; } - -{ use integer; my $x; $x ++; ok 28, ! uninitialized; } -{ use integer; my $x; $x --; ok 29, ! uninitialized; } -{ use integer; my $x; ++ $x; ok 30, ! uninitialized; } -{ use integer; my $x; -- $x; ok 31, ! uninitialized; } - -ok 32, $warn eq ''; - -# If we got any errors that we were not expecting, then print them -print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t deleted file mode 100755 index 2702004..0000000 --- a/contrib/perl5/t/op/attrs.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl -w - -# Regression tests for attributes.pm and the C< : attrs> syntax. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -sub NTESTS () ; - -my ($test, $ntests); -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; - -$SIG{__WARN__} = sub { die @_ }; - -sub mytest { - if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { - if ($@) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# Got: $x\n" - } - else { - print "# Got unexpected success\n"; - } - if ($_[0]) { - print "# Expected: $_[0]\n"; - } - else { - print "# Expected success\n"; - } - $failed = 1; - print "not "; - } - elsif (@_ == 3 && $_[1] ne $_[2]) { - print "# Got: $_[1]\n"; - print "# Expected: $_[2]\n"; - $failed = 1; - print "not "; - } - print "ok ",++$test,"\n"; -} - -eval 'sub t1 ($) : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t2 : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -mytest; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -mytest; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub : locked : method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub : method { $_[0]->[1] }'; -mytest; -BEGIN {++$ntests} - -eval 'sub e1 ($) : plugh ;'; -mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; -BEGIN {++$ntests} - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; -BEGIN {++$ntests} - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -mytest qr/Unterminated attribute parameter in attribute list at/; -BEGIN {++$ntests} - -eval 'sub e4 ($) : plugh + xyzzy ;'; -mytest qr/Invalid separator character '[+]' in attribute list at/; -BEGIN {++$ntests} - -eval 'my main $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : plugh;'; -mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; -BEGIN {++$ntests} - -sub A::MODIFY_SCALAR_ATTRIBUTES { return } -eval 'my A $x : plugh;'; -mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; -BEGIN {++$ntests} - -eval 'my A $x : plugh plover;'; -mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; -BEGIN {++$ntests} - -sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } -sub X::foo { 1 } -*Y::bar = \&X::foo; -*Y::bar = \&X::foo; # second time for -w -eval 'package Z; sub Y::bar : locked'; -mytest qr/^X at /; -BEGIN {++$ntests} - -my @attrs = eval 'attributes::get \&Y::bar'; -mytest '', "@attrs", "locked"; -BEGIN {++$ntests} - -@attrs = eval 'attributes::get $anon1'; -mytest '', "@attrs", "locked method"; -BEGIN {++$ntests} - -sub Z::DESTROY { } -sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } -my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; -mytest '', ref($thunk), "Z"; -BEGIN {++$ntests} - -@attrs = eval 'attributes::get $thunk'; -mytest '', "@attrs", "locked method Z"; -BEGIN {++$ntests} - - -# Other tests should be added above this line - -sub NTESTS () { $ntests } - -exit $failed; diff --git a/contrib/perl5/t/op/auto.t b/contrib/perl5/t/op/auto.t deleted file mode 100755 index 2eb0097..0000000 --- a/contrib/perl5/t/op/auto.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl - -# $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $ - -print "1..37\n"; - -$x = 10000; -if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";} -if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";} -if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";} -if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";} -if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";} -if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";} -if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";} -if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";} -if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";} -if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";} - -$x[0] = 10000; -if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";} -if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";} -if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";} -if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";} -if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";} -if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";} -if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";} -if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";} -if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";} -if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";} - -$x{0} = 10000; -if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";} -if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";} -if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";} -if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";} -if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";} -if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";} -if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";} -if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";} -if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";} -if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";} - -# test magical autoincrement - -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/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t deleted file mode 100755 index 5b91fd2..0000000 --- a/contrib/perl5/t/op/avhv.t +++ /dev/null @@ -1,178 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -require Tie::Array; - -package Tie::BasicArray; -@ISA = 'Tie::Array'; -sub TIEARRAY { bless [], $_[0] } -sub STORE { $_[0]->[$_[1]] = $_[2] } -sub FETCH { $_[0]->[$_[1]] } -sub FETCHSIZE { scalar(@{$_[0]})} -sub STORESIZE { $#{$_[0]} = $_[1]+1 } - -package main; - -print "1..28\n"; - -$sch = { - 'abc' => 1, - 'def' => 2, - 'jkl' => 3, -}; - -# basic normal array -$a = []; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -$a->{'def'} = 'DEF'; -$a->{'jkl'} = 'JKL'; - -@keys = keys %$a; -@values = values %$a; - -if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";} - -$i = 0; # stop -w complaints - -while (($key,$value) = each %$a) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";} - -# quick check with tied array -tie @fake, 'Tie::StdArray'; -$a = \@fake; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";} - -# quick check with tied array -tie @fake, 'Tie::BasicArray'; -$a = \@fake; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";} - -# quick check with tied array & tied hash -require Tie::Hash; -tie %fake, Tie::StdHash; -%fake = %$sch; -$a->[0] = \%fake; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";} - -# hash slice -my $slice = join('', 'x',@$a{'abc','def'},'x'); -print "not " if $slice ne 'xABCx'; -print "ok 6\n"; - -# evaluation in scalar context -my $avhv = [{}]; -print "not " if %$avhv; -print "ok 7\n"; - -push @$avhv, "a"; -print "not " if %$avhv; -print "ok 8\n"; - -$avhv = []; -eval { $a = %$avhv }; -print "not " unless $@ and $@ =~ /^Can't coerce array into hash/; -print "ok 9\n"; - -$avhv = [{foo=>1, bar=>2}]; -print "not " unless %$avhv =~ m,^\d+/\d+,; -print "ok 10\n"; - -# check if defelem magic works -sub f { - print "not " unless $_[0] eq 'a'; - $_[0] = 'b'; - print "ok 11\n"; -} -$a = [{key => 1}, 'a']; -f($a->{key}); -print "not " unless $a->[1] eq 'b'; -print "ok 12\n"; - -# check if exists() is behaving properly -$avhv = [{foo=>1,bar=>2,pants=>3}]; -print "not " if exists $avhv->{bar}; -print "ok 13\n"; - -$avhv->{pants} = undef; -print "not " unless exists $avhv->{pants}; -print "ok 14\n"; -print "not " if exists $avhv->{bar}; -print "ok 15\n"; - -$avhv->{bar} = 10; -print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; -print "ok 16\n"; - -$v = delete $avhv->{bar}; -print "not " unless $v == 10; -print "ok 17\n"; - -print "not " if exists $avhv->{bar}; -print "ok 18\n"; - -$avhv->{foo} = 'xxx'; -$avhv->{bar} = 'yyy'; -$avhv->{pants} = 'zzz'; -@x = delete @{$avhv}{'foo','pants'}; -print "# @x\nnot " unless "@x" eq "xxx zzz"; -print "ok 19\n"; - -print "not " unless "$avhv->{bar}" eq "yyy"; -print "ok 20\n"; - -# hash assignment -%$avhv = (); -print "not " unless ref($avhv->[0]) eq 'HASH'; -print "ok 21\n"; - -%hv = %$avhv; -print "not " if grep defined, values %hv; -print "ok 22\n"; -print "not " if grep ref, keys %hv; -print "ok 23\n"; - -%$avhv = (foo => 29, pants => 2, bar => 0); -print "not " unless "@$avhv[1..3]" eq '29 0 2'; -print "ok 24\n"; - -my $extra; -my @extra; -($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; -print "ok 25\n"; - -%$avhv = (); -(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; -print "ok 26\n"; - -@extra = qw(whatever and stuff); -%$avhv = (); -(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; -print "ok 27\n"; - -%$avhv = (); -(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; -print "ok 28\n"; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t deleted file mode 100755 index 0354f00..0000000 --- a/contrib/perl5/t/op/bop.t +++ /dev/null @@ -1,171 +0,0 @@ -#!./perl - -# -# test the bit operators '&', '|', '^', '~', '<<', and '>>' -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..44\n"; - -# numerics -print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); -print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); -print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); -print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); - -# shifts -print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); -print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); - -# signed vs. unsigned -print ((~0 > 0 && do { use integer; ~0 } == -1) - ? "ok 7\n" : "not ok 7\n"); - -my $bits = 0; -for (my $i = ~0; $i; $i >>= 1) { ++$bits; } -my $cusp = 1 << ($bits - 1); - -print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0) - ? "ok 8\n" : "not ok 8\n"); -print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0) - ? "ok 9\n" : "not ok 9\n"); -print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0) - ? "ok 10\n" : "not ok 10\n"); -print (((1 << ($bits - 1)) == $cusp && - do { use integer; 1 << ($bits - 1) } == -$cusp) - ? "ok 11\n" : "not ok 11\n"); -print ((($cusp >> 1) == ($cusp / 2) && - do { use integer; abs($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 ($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; -$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"); - -# -print "ok \xFF\xFF\n" & "ok 19\n"; -print "ok 20\n" | "ok \0\0\n"; -print "o\000 \0001\000" ^ "\000k\0002\000\n"; - -# -print "ok \x{FF}\x{FF}\n" & "ok 22\n"; -print "ok 23\n" | "ok \x{0}\x{0}\n"; -print "o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n"; - -# -print "ok 25\n" if sprintf("%vd", v4095 & v801) eq 801; -print "ok 26\n" if sprintf("%vd", v4095 | v801) eq 4095; -print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; - -# -print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; -print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; -print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; -# -print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256'; -print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444'; -print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188'; -# -my $a = v120.300; -my $b = v200.400; -$a ^= $b; -print "ok 34\n" if sprintf("%vd", $a) eq '176.188'; -my $a = v120.300; -my $b = v200.400; -$a |= $b; -print "ok 35\n" if sprintf("%vd", $a) eq '248.444'; - -# -# UTF8 ~ behaviour -# - -my @not36; - -for (0x100...0xFFF) { - $a = ~(chr $_); - push @not36, sprintf("%#03X", $_) - if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); -} -if (@not36) { - print "# test 36 failed\n"; - print "not "; -} -print "ok 36\n"; - -my @not37; - -for my $i (0xEEE...0xF00) { - for my $j (0x0..0x120) { - $a = ~(chr ($i) . chr $j); - push @not37, sprintf("%#03X %#03X", $i, $j) - if $a ne chr(~$i).chr(~$j) or - length($a) != 2 or - ~$a ne chr($i).chr($j); - } -} -if (@not37) { - print "# test 37 failed\n"; - print "not "; -} -print "ok 37\n"; - -print "not " unless ~chr(~0) eq "\0"; -print "ok 38\n"; - -my @not39; - -for my $i (0x100..0x120) { - for my $j (0x100...0x120) { - push @not39, sprintf("%#03X %#03X", $i, $j) - if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); - } -} -if (@not39) { - print "# test 39 failed\n"; - print "not "; -} -print "ok 39\n"; - -my @not40; - -for my $i (0x100..0x120) { - for my $j (0x100...0x120) { - push @not40, sprintf("%#03X %#03X", $i, $j) - if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); - } -} -if (@not40) { - print "# test 40 failed\n"; - print "not "; -} -print "ok 40\n"; - -# More variations on 19 and 22. -print "ok \xFF\x{FF}\n" & "ok 41\n"; -print "ok \x{FF}\xFF\n" & "ok 42\n"; - -# Tests to see if you really can do casts negative floats to unsigned properly -$neg1 = -1.0; -print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n"); -$neg7 = -7.0; -print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n"); diff --git a/contrib/perl5/t/op/chars.t b/contrib/perl5/t/op/chars.t deleted file mode 100755 index efdea02..0000000 --- a/contrib/perl5/t/op/chars.t +++ /dev/null @@ -1,74 +0,0 @@ -#!./perl - -print "1..33\n"; - -# because of ebcdic.c these should be the same on asciiish -# and ebcdic machines. -# Peter Prymmer <pvhp@best.com>. - -my $c = "\c@"; -print +((ord($c) == 0) ? "" : "not "),"ok 1\n"; -$c = "\cA"; -print +((ord($c) == 1) ? "" : "not "),"ok 2\n"; -$c = "\cB"; -print +((ord($c) == 2) ? "" : "not "),"ok 3\n"; -$c = "\cC"; -print +((ord($c) == 3) ? "" : "not "),"ok 4\n"; -$c = "\cD"; -print +((ord($c) == 4) ? "" : "not "),"ok 5\n"; -$c = "\cE"; -print +((ord($c) == 5) ? "" : "not "),"ok 6\n"; -$c = "\cF"; -print +((ord($c) == 6) ? "" : "not "),"ok 7\n"; -$c = "\cG"; -print +((ord($c) == 7) ? "" : "not "),"ok 8\n"; -$c = "\cH"; -print +((ord($c) == 8) ? "" : "not "),"ok 9\n"; -$c = "\cI"; -print +((ord($c) == 9) ? "" : "not "),"ok 10\n"; -$c = "\cJ"; -print +((ord($c) == 10) ? "" : "not "),"ok 11\n"; -$c = "\cK"; -print +((ord($c) == 11) ? "" : "not "),"ok 12\n"; -$c = "\cL"; -print +((ord($c) == 12) ? "" : "not "),"ok 13\n"; -$c = "\cM"; -print +((ord($c) == 13) ? "" : "not "),"ok 14\n"; -$c = "\cN"; -print +((ord($c) == 14) ? "" : "not "),"ok 15\n"; -$c = "\cO"; -print +((ord($c) == 15) ? "" : "not "),"ok 16\n"; -$c = "\cP"; -print +((ord($c) == 16) ? "" : "not "),"ok 17\n"; -$c = "\cQ"; -print +((ord($c) == 17) ? "" : "not "),"ok 18\n"; -$c = "\cR"; -print +((ord($c) == 18) ? "" : "not "),"ok 19\n"; -$c = "\cS"; -print +((ord($c) == 19) ? "" : "not "),"ok 20\n"; -$c = "\cT"; -print +((ord($c) == 20) ? "" : "not "),"ok 21\n"; -$c = "\cU"; -print +((ord($c) == 21) ? "" : "not "),"ok 22\n"; -$c = "\cV"; -print +((ord($c) == 22) ? "" : "not "),"ok 23\n"; -$c = "\cW"; -print +((ord($c) == 23) ? "" : "not "),"ok 24\n"; -$c = "\cX"; -print +((ord($c) == 24) ? "" : "not "),"ok 25\n"; -$c = "\cY"; -print +((ord($c) == 25) ? "" : "not "),"ok 26\n"; -$c = "\cZ"; -print +((ord($c) == 26) ? "" : "not "),"ok 27\n"; -$c = "\c["; -print +((ord($c) == 27) ? "" : "not "),"ok 28\n"; -$c = "\c\\"; -print +((ord($c) == 28) ? "" : "not "),"ok 29\n"; -$c = "\c]"; -print +((ord($c) == 29) ? "" : "not "),"ok 30\n"; -$c = "\c^"; -print +((ord($c) == 30) ? "" : "not "),"ok 31\n"; -$c = "\c_"; -print +((ord($c) == 31) ? "" : "not "),"ok 32\n"; -$c = "\c?"; -print +((ord($c) == 127) ? "" : "not "),"ok 33\n"; diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t deleted file mode 100755 index 1b55f11..0000000 --- a/contrib/perl5/t/op/chop.t +++ /dev/null @@ -1,118 +0,0 @@ -#!./perl - -print "1..37\n"; - -# optimized - -$_ = 'abc'; -$c = do foo(); -if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";} - -# unoptimized - -$_ = 'abc'; -$c = chop($_); -if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";} - -sub foo { - chop; -} - -@foo = ("hi \n","there\n","!\n"); -@bar = @foo; -chop(@bar); -print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n"; - -$foo = "\n"; -chop($foo,@foo); -print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n"; - -$_ = "foo\n\n"; -print chomp() == 1 ? "ok 5\n" : "not ok 5\n"; -print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n"; - -$_ = "foo\n"; -print chomp() == 1 ? "ok 7\n" : "not ok 7\n"; -print $_ eq "foo" ? "ok 8\n" : "not ok 8\n"; - -$_ = "foo"; -print chomp() == 0 ? "ok 9\n" : "not ok 9\n"; -print $_ eq "foo" ? "ok 10\n" : "not ok 10\n"; - -$_ = "foo"; -$/ = "oo"; -print chomp() == 2 ? "ok 11\n" : "not ok 11\n"; -print $_ eq "f" ? "ok 12\n" : "not ok 12\n"; - -$_ = "bar"; -$/ = "oo"; -print chomp() == 0 ? "ok 13\n" : "not ok 13\n"; -print $_ eq "bar" ? "ok 14\n" : "not ok 14\n"; - -$_ = "f\n\n\n\n\n"; -$/ = ""; -print chomp() == 5 ? "ok 15\n" : "not ok 15\n"; -print $_ eq "f" ? "ok 16\n" : "not ok 16\n"; - -$_ = "f\n\n"; -$/ = ""; -print chomp() == 2 ? "ok 17\n" : "not ok 17\n"; -print $_ eq "f" ? "ok 18\n" : "not ok 18\n"; - -$_ = "f\n"; -$/ = ""; -print chomp() == 1 ? "ok 19\n" : "not ok 19\n"; -print $_ eq "f" ? "ok 20\n" : "not ok 20\n"; - -$_ = "f"; -$/ = ""; -print chomp() == 0 ? "ok 21\n" : "not ok 21\n"; -print $_ eq "f" ? "ok 22\n" : "not ok 22\n"; - -$_ = "xx"; -$/ = "xx"; -print chomp() == 2 ? "ok 23\n" : "not ok 23\n"; -print $_ eq "" ? "ok 24\n" : "not ok 24\n"; - -$_ = "axx"; -$/ = "xx"; -print chomp() == 2 ? "ok 25\n" : "not ok 25\n"; -print $_ eq "a" ? "ok 26\n" : "not ok 26\n"; - -$_ = "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"; - -# Go Unicode. - -$_ = "abc\x{1234}"; -chop; -print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; - -$_ = "abc\x{1234}d"; -chop; -print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; - -$_ = "\x{1234}\x{2345}"; -chop; -print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; - -my @stuff = qw(this that); -print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; - -# bug id 20010305.012 -@stuff = qw(ab cd ef); -print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; - -@stuff = qw(ab cd ef); -print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; - -my %stuff = (1..4); -print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t deleted file mode 100755 index 5f3245f..0000000 --- a/contrib/perl5/t/op/closure.t +++ /dev/null @@ -1,507 +0,0 @@ -#!./perl -# -*- Mode: Perl -*- -# closure.t: -# Original written by Ulrich Pfeifer on 2 Jan 1997. -# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -print "1..171\n"; - -my $test = 1; -sub test (&) { - print ((&{$_[0]})?"ok $test\n":"not ok $test\n"); - $test++; -} - -my $i = 1; -sub foo { $i = shift if @_; $i } - -# no closure -test { foo == 1 }; -foo(2); -test { foo == 2 }; - -# closure: lexical outside sub -my $foo = sub {$i = shift if @_; $i }; -my $bar = sub {$i = shift if @_; $i }; -test {&$foo() == 2 }; -&$foo(3); -test {&$foo() == 3 }; -# did the lexical change? -test { foo == 3 and $i == 3}; -# did the second closure notice? -test {&$bar() == 3 }; - -# closure: lexical inside sub -sub bar { - my $i = shift; - sub { $i = shift if @_; $i } -} - -$foo = bar(4); -$bar = bar(5); -test {&$foo() == 4 }; -&$foo(6); -test {&$foo() == 6 }; -test {&$bar() == 5 }; - -# nested closures -sub bizz { - my $i = 7; - if (@_) { - my $i = shift; - sub {$i = shift if @_; $i }; - } else { - my $i = $i; - sub {$i = shift if @_; $i }; - } -} -$foo = bizz(); -$bar = bizz(); -test {&$foo() == 7 }; -&$foo(8); -test {&$foo() == 8 }; -test {&$bar() == 7 }; - -$foo = bizz(9); -$bar = bizz(10); -test {&$foo(11)-1 == &$bar()}; - -my @foo; -for (qw(0 1 2 3 4)) { - my $i = $_; - $foo[$_] = sub {$i = shift if @_; $i }; -} - -test { - &{$foo[0]}() == 0 and - &{$foo[1]}() == 1 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 3 and - &{$foo[4]}() == 4 - }; - -for (0 .. 4) { - &{$foo[$_]}(4-$_); -} - -test { - &{$foo[0]}() == 4 and - &{$foo[1]}() == 3 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 1 and - &{$foo[4]}() == 0 - }; - -sub barf { - my @foo; - for (qw(0 1 2 3 4)) { - my $i = $_; - $foo[$_] = sub {$i = shift if @_; $i }; - } - @foo; -} - -@foo = barf(); -test { - &{$foo[0]}() == 0 and - &{$foo[1]}() == 1 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 3 and - &{$foo[4]}() == 4 - }; - -for (0 .. 4) { - &{$foo[$_]}(4-$_); -} - -test { - &{$foo[0]}() == 4 and - &{$foo[1]}() == 3 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 1 and - &{$foo[4]}() == 0 - }; - -# test if closures get created in optimized for loops - -my %foo; -for my $n ('A'..'E') { - $foo{$n} = sub { $n eq $_[0] }; -} - -test { - &{$foo{A}}('A') and - &{$foo{B}}('B') and - &{$foo{C}}('C') and - &{$foo{D}}('D') and - &{$foo{E}}('E') -}; - -for my $n (0..4) { - $foo[$n] = sub { $n == $_[0] }; -} - -test { - &{$foo[0]}(0) and - &{$foo[1]}(1) and - &{$foo[2]}(2) and - &{$foo[3]}(3) and - &{$foo[4]}(4) -}; - -for my $n (0..4) { - $foo[$n] = sub { - # no intervening reference to $n here - sub { $n == $_[0] } - }; -} - -test { - $foo[0]->()->(0) and - $foo[1]->()->(1) and - $foo[2]->()->(2) and - $foo[3]->()->(3) and - $foo[4]->()->(4) -}; - -{ - my $w; - $w = sub { - my ($i) = @_; - test { $i == 10 }; - sub { $w }; - }; - $w->(10); -} - -# Additional tests by Tom Phoenix <rootbeer@teleport.com>. - -{ - use strict; - - use vars qw!$test!; - my($debugging, %expected, $inner_type, $where_declared, $within); - my($nc_attempt, $call_outer, $call_inner, $undef_outer); - my($code, $inner_sub_test, $expected, $line, $errors, $output); - my(@inners, $sub_test, $pid); - $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; - - # The expected values for these tests - %expected = ( - 'global_scalar' => 1001, - 'global_array' => 2101, - 'global_hash' => 3004, - 'fs_scalar' => 4001, - 'fs_array' => 5101, - 'fs_hash' => 6004, - 'sub_scalar' => 7001, - 'sub_array' => 8101, - 'sub_hash' => 9004, - 'foreach' => 10011, - ); - - # Our innermost sub is either named or anonymous - for $inner_type (qw!named anon!) { - # And it may be declared at filescope, within a named - # sub, or within an anon sub - for $where_declared (qw!filescope in_named in_anon!) { - # And that, in turn, may be within a foreach loop, - # a naked block, or another named sub - for $within (qw!foreach naked other_sub!) { - - # Here are a number of variables which show what's - # going on, in a way. - $nc_attempt = 0+ # Named closure attempted - ( ($inner_type eq 'named') || - ($within eq 'other_sub') ) ; - $call_inner = 0+ # Need to call &inner - ( ($inner_type eq 'anon') && - ($within eq 'other_sub') ) ; - $call_outer = 0+ # Need to call &outer or &$outer - ( ($inner_type eq 'anon') && - ($within ne 'other_sub') ) ; - $undef_outer = 0+ # $outer is created but unused - ( ($where_declared eq 'in_anon') && - (not $call_outer) ) ; - - $code = "# This is a test script built by t/op/closure.t\n\n"; - - $code .= <<"DEBUG_INFO" if $debugging; -# inner_type: $inner_type -# where_declared: $where_declared -# within: $within -# nc_attempt: $nc_attempt -# call_inner: $call_inner -# call_outer: $call_outer -# undef_outer: $undef_outer -DEBUG_INFO - - $code .= <<"END_MARK_ONE"; - -BEGIN { \$SIG{__WARN__} = sub { - my \$msg = \$_[0]; -END_MARK_ONE - - $code .= <<"END_MARK_TWO" if $nc_attempt; - return if index(\$msg, 'will not stay shared') != -1; - return if index(\$msg, 'may be unavailable') != -1; -END_MARK_TWO - - $code .= <<"END_MARK_THREE"; # Backwhack a lot! - print "not ok: got unexpected warning \$msg\\n"; -} } - -{ - my \$test = $test; - sub test (&) { - my \$result = &{\$_[0]}; - print "not " unless \$result; - print "ok \$test\\n"; - \$test++; - } -} - -# some of the variables which the closure will access -\$global_scalar = 1000; -\@global_array = (2000, 2100, 2200, 2300); -%global_hash = 3000..3009; - -my \$fs_scalar = 4000; -my \@fs_array = (5000, 5100, 5200, 5300); -my %fs_hash = 6000..6009; - -END_MARK_THREE - - if ($where_declared eq 'filescope') { - # Nothing here - } elsif ($where_declared eq 'in_named') { - $code .= <<'END'; -sub outer { - my $sub_scalar = 7000; - my @sub_array = (8000, 8100, 8200, 8300); - my %sub_hash = 9000..9009; -END - # } - } elsif ($where_declared eq 'in_anon') { - $code .= <<'END'; -$outer = sub { - my $sub_scalar = 7000; - my @sub_array = (8000, 8100, 8200, 8300); - my %sub_hash = 9000..9009; -END - # } - } else { - die "What was $where_declared?" - } - - if ($within eq 'foreach') { - $code .= " - my \$foreach = 12000; - my \@list = (10000, 10010); - foreach \$foreach (\@list) { - " # } - } elsif ($within eq 'naked') { - $code .= " { # naked block\n" # } - } elsif ($within eq 'other_sub') { - $code .= " sub inner_sub {\n" # } - } else { - die "What was $within?" - } - - $sub_test = $test; - @inners = ( qw!global_scalar global_array global_hash! , - qw!fs_scalar fs_array fs_hash! ); - push @inners, 'foreach' if $within eq 'foreach'; - if ($where_declared ne 'filescope') { - push @inners, qw!sub_scalar sub_array sub_hash!; - } - for $inner_sub_test (@inners) { - - if ($inner_type eq 'named') { - $code .= " sub named_$sub_test " - } elsif ($inner_type eq 'anon') { - $code .= " \$anon_$sub_test = sub " - } else { - die "What was $inner_type?" - } - - # Now to write the body of the test sub - if ($inner_sub_test eq 'global_scalar') { - $code .= '{ ++$global_scalar }' - } elsif ($inner_sub_test eq 'fs_scalar') { - $code .= '{ ++$fs_scalar }' - } elsif ($inner_sub_test eq 'sub_scalar') { - $code .= '{ ++$sub_scalar }' - } elsif ($inner_sub_test eq 'global_array') { - $code .= '{ ++$global_array[1] }' - } elsif ($inner_sub_test eq 'fs_array') { - $code .= '{ ++$fs_array[1] }' - } elsif ($inner_sub_test eq 'sub_array') { - $code .= '{ ++$sub_array[1] }' - } elsif ($inner_sub_test eq 'global_hash') { - $code .= '{ ++$global_hash{3002} }' - } elsif ($inner_sub_test eq 'fs_hash') { - $code .= '{ ++$fs_hash{6002} }' - } elsif ($inner_sub_test eq 'sub_hash') { - $code .= '{ ++$sub_hash{9002} }' - } elsif ($inner_sub_test eq 'foreach') { - $code .= '{ ++$foreach }' - } else { - die "What was $inner_sub_test?" - } - - # Close up - if ($inner_type eq 'anon') { - $code .= ';' - } - $code .= "\n"; - $sub_test++; # sub name sequence number - - } # End of foreach $inner_sub_test - - # Close up $within block # { - $code .= " }\n\n"; - - # Close up $where_declared block - if ($where_declared eq 'in_named') { # { - $code .= "}\n\n"; - } elsif ($where_declared eq 'in_anon') { # { - $code .= "};\n\n"; - } - - # We may need to do something with the sub we just made... - $code .= "undef \$outer;\n" if $undef_outer; - $code .= "&inner_sub;\n" if $call_inner; - if ($call_outer) { - if ($where_declared eq 'in_named') { - $code .= "&outer;\n\n"; - } elsif ($where_declared eq 'in_anon') { - $code .= "&\$outer;\n\n" - } - } - - # Now, we can actually prep to run the tests. - for $inner_sub_test (@inners) { - $expected = $expected{$inner_sub_test} or - die "expected $inner_sub_test missing"; - - # Named closures won't access the expected vars - if ( $nc_attempt and - substr($inner_sub_test, 0, 4) eq "sub_" ) { - $expected = 1; - } - - # If you make a sub within a foreach loop, - # what happens if it tries to access the - # foreach index variable? If it's a named - # sub, it gets the var from "outside" the loop, - # but if it's anon, it gets the value to which - # the index variable is aliased. - # - # Of course, if the value was set only - # within another sub which was never called, - # the value has not been set yet. - # - if ($inner_sub_test eq 'foreach') { - if ($inner_type eq 'named') { - if ($call_outer || ($where_declared eq 'filescope')) { - $expected = 12001 - } else { - $expected = 1 - } - } - } - - # Here's the test: - if ($inner_type eq 'anon') { - $code .= "test { &\$anon_$test == $expected };\n" - } else { - $code .= "test { &named_$test == $expected };\n" - } - $test++; - } - - if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') { - # Fork off a new perl to run the tests. - # (This is so we can catch spurious warnings.) - $| = 1; print ""; $| = 0; # flush output before forking - pipe READ, WRITE or die "Can't make pipe: $!"; - pipe READ2, WRITE2 or die "Can't make second pipe: $!"; - die "Can't fork: $!" unless defined($pid = open PERL, "|-"); - unless ($pid) { - # Child process here. We're going to send errors back - # through the extra pipe. - close READ; - close READ2; - open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; - open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; - exec './perl', '-w', '-' - or die "Can't exec ./perl: $!"; - } else { - # Parent process here. - close WRITE; - close WRITE2; - print PERL $code; - close PERL; - { local $/; - $output = join '', <READ>; - $errors = join '', <READ2>; } - close READ; - close READ2; - } - } else { - # No fork(). Do it the hard way. - my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; - my $errfile = "terr$$"; $errfile++ while -e $errfile; - my @tmpfiles = ($cmdfile, $errfile); - open CMD, ">$cmdfile"; print CMD $code; close CMD; - my $cmd = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : './perl'); - $cmd .= " -w $cmdfile 2>$errfile"; - if ($^O eq 'VMS' or $^O eq 'MSWin32') { - # Use pipe instead of system so we don't inherit STD* from - # this process, and then foul our pipe back to parent by - # redirecting output in the child. - open PERL,"$cmd |" or die "Can't open pipe: $!\n"; - { local $/; $output = join '', <PERL> } - close PERL; - } else { - my $outfile = "tout$$"; $outfile++ while -e $outfile; - push @tmpfiles, $outfile; - system "$cmd >$outfile"; - { local $/; open IN, $outfile; $output = <IN>; close IN } - } - if ($?) { - printf "not ok: exited with error code %04X\n", $?; - $debugging or do { 1 while unlink @tmpfiles }; - exit; - } - { local $/; open IN, $errfile; $errors = <IN>; close IN } - 1 while unlink @tmpfiles; - } - print $output; - print STDERR $errors; - if ($debugging && ($errors || $? || ($output =~ /not ok/))) { - my $lnum = 0; - for $line (split '\n', $code) { - printf "%3d: %s\n", ++$lnum, $line; - } - } - printf "not ok: exited with error code %04X\n", $? if $?; - print "-" x 30, "\n" if $debugging; - - } # End of foreach $within - } # End of foreach $where_declared - } # End of foreach $inner_type - -} - diff --git a/contrib/perl5/t/op/cmp.t b/contrib/perl5/t/op/cmp.t deleted file mode 100755 index 4a7e68d..0000000 --- a/contrib/perl5/t/op/cmp.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); - -$expect = ($#FOO+2) * ($#FOO+1); -print "1..$expect\n"; - -my $ok = 0; -for my $i (0..$#FOO) { - for my $j ($i..$#FOO) { - $ok++; - my $cmp = $FOO[$i] <=> $FOO[$j]; - if (!defined($cmp) || - $cmp == -1 && $FOO[$i] < $FOO[$j] || - $cmp == 0 && $FOO[$i] == $FOO[$j] || - $cmp == 1 && $FOO[$i] > $FOO[$j]) - { - print "ok $ok\n"; - } - else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; - } - $ok++; - $cmp = $FOO[$i] cmp $FOO[$j]; - if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || - $cmp == 0 && $FOO[$i] eq $FOO[$j] || - $cmp == 1 && $FOO[$i] gt $FOO[$j]) - { - print "ok $ok\n"; - } - else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; - } - } -} diff --git a/contrib/perl5/t/op/concat.t b/contrib/perl5/t/op/concat.t deleted file mode 100755 index 76074e0..0000000 --- a/contrib/perl5/t/op/concat.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..11\n"; - -($a, $b, $c) = qw(foo bar); - -print "not " unless "$a" eq "foo"; -print "ok 1\n"; - -print "not " unless "$a$b" eq "foobar"; -print "ok 2\n"; - -print "not " unless "$c$a$c" eq "foo"; -print "ok 3\n"; - -# Okay, so that wasn't very challenging. Let's go Unicode. - -my $test = 4; - -{ - # bug id 20000819.004 - - $_ = $dx = "\x{10f2}"; - s/($dx)/$dx$1/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $_ = $dx = "\x{10f2}"; - s/($dx)/$1$dx/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $dx = "\x{10f2}"; - $_ = "\x{10f2}\x{10f2}"; - s/($dx)($dx)/$1$2/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } -} - -{ - # bug id 20000901.092 - # test that undef left and right of utf8 results in a valid string - - my $a; - $a .= "\x{1ff}"; - print "not " unless $a eq "\x{1ff}"; - print "ok $test\n"; - $test++; -} - -{ - # ID 20001020.006 - - "x" =~ /(.)/; # unset $2 - - # Without the fix this 5.7.0 would croak: - # Modification of a read-only value attempted at ... - "$2\x{1234}"; - - print "ok $test\n"; - $test++; - - # For symmetry with the above. - "\x{1234}$2"; - - print "ok $test\n"; - $test++; - - *pi = \undef; - # This bug existed earlier than the $2 bug, but is fixed with the same - # patch. Without the fix this 5.7.0 would also croak: - # Modification of a read-only value attempted at ... - "$pi\x{1234}"; - - print "ok $test\n"; - $test++; - - # For symmetry with the above. - "\x{1234}$pi"; - - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/cond.t b/contrib/perl5/t/op/cond.t deleted file mode 100755 index 427efb4..0000000 --- a/contrib/perl5/t/op/cond.t +++ /dev/null @@ -1,12 +0,0 @@ -#!./perl - -# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:41 $ - -print "1..4\n"; - -print 1 ? "ok 1\n" : "not ok 1\n"; # compile time -print 0 ? "not ok 2\n" : "ok 2\n"; - -$x = 1; -print $x ? "ok 3\n" : "not ok 3\n"; # run time -print !$x ? "not ok 4\n" : "ok 4\n"; diff --git a/contrib/perl5/t/op/context.t b/contrib/perl5/t/op/context.t deleted file mode 100755 index 4625441..0000000 --- a/contrib/perl5/t/op/context.t +++ /dev/null @@ -1,18 +0,0 @@ -#!./perl - -$n=0; - -print "1..3\n"; - -sub foo { - $a='abcd'; - - $a=~/(.)/g; - - $1 eq 'a' or print 'not '; - print "ok ",++$n,"\n"; -} - -$a=foo; -@a=foo; -foo; diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t deleted file mode 100755 index 33c74ea..0000000 --- a/contrib/perl5/t/op/defins.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./perl -w - -# -# test auto defined() test insertion -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { $warns++; warn $_[0] }; - print "1..14\n"; -} - -$wanted_filename = $^O eq 'VMS' ? '0.' : '0'; - -print "not " if $warns; -print "ok 1\n"; - -open(FILE,">./0"); -print FILE "1\n"; -print FILE "0"; -close(FILE); - -open(FILE,"<./0"); -my $seen = 0; -my $dummy; -while (my $name = <FILE>) - { - $seen++ if $name eq '0'; - } -print "not " unless $seen; -print "ok 2\n"; - -seek(FILE,0,0); -$seen = 0; -my $line = ''; -do - { - $seen++ if $line eq '0'; - } while ($line = <FILE>); - -print "not " unless $seen; -print "ok 3\n"; - - -seek(FILE,0,0); -$seen = 0; -while (($seen ? $dummy : $name) = <FILE>) - { - $seen++ if $name eq '0'; - } -print "not " unless $seen; -print "ok 4\n"; - -seek(FILE,0,0); -$seen = 0; -my %where; -while ($where{$seen} = <FILE>) - { - $seen++ if $where{$seen} eq '0'; - } -print "not " unless $seen; -print "ok 5\n"; -close FILE; - -opendir(DIR,'.'); -$seen = 0; -while (my $name = readdir(DIR)) - { - $seen++ if $name eq $wanted_filename; - } -print "not " unless $seen; -print "ok 6\n"; - -rewinddir(DIR); -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = readdir(DIR)) - { - $seen++ if $name eq $wanted_filename; - } -print "not " unless $seen; -print "ok 7\n"; - -rewinddir(DIR); -$seen = 0; -while ($where{$seen} = readdir(DIR)) - { - $seen++ if $where{$seen} eq $wanted_filename; - } -print "not " unless $seen; -print "ok 8\n"; - -$seen = 0; -while (my $name = glob('*')) - { - $seen++ if $name eq $wanted_filename; - } -print "not " unless $seen; -print "ok 9\n"; - -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = glob('*')) - { - $seen++ if $name eq $wanted_filename; - } -print "not " unless $seen; -print "ok 10\n"; - -$seen = 0; -while ($where{$seen} = glob('*')) - { - $seen++ if $where{$seen} eq $wanted_filename; - } -print "not " unless $seen; -print "ok 11\n"; - -unlink("./0"); - -my %hash = (0 => 1, 1 => 2); - -$seen = 0; -while (my $name = each %hash) - { - $seen++ if $name eq '0'; - } -print "not " unless $seen; -print "ok 12\n"; - -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = each %hash) - { - $seen++ if $name eq '0'; - } -print "not " unless $seen; -print "ok 13\n"; - -$seen = 0; -while ($where{$seen} = each %hash) - { - $seen++ if $where{$seen} eq '0'; - } -print "not " unless $seen; -print "ok 14\n"; - diff --git a/contrib/perl5/t/op/delete.t b/contrib/perl5/t/op/delete.t deleted file mode 100755 index 10a218b..0000000 --- a/contrib/perl5/t/op/delete.t +++ /dev/null @@ -1,123 +0,0 @@ -#!./perl - -print "1..36\n"; - -# delete() on hash elements - -$foo{1} = 'a'; -$foo{2} = 'b'; -$foo{3} = 'c'; -$foo{4} = 'd'; -$foo{5} = 'e'; - -$foo = delete $foo{2}; - -if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} -if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} -if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} -if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} -if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} - -@foo = delete @foo{4, 5}; - -if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} -if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} -if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} -if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} -if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} - -$foo = join('',values(%foo)); -if ($foo eq 'ac' || $foo eq 'ca') {print "ok 14\n";} else {print "not ok 14\n";} - -foreach $key (keys %foo) { - delete $foo{$key}; -} - -$foo{'foo'} = 'x'; -$foo{'bar'} = 'y'; - -$foo = join('',values(%foo)); -print +($foo eq 'xy' || $foo eq 'yx') ? "ok 15\n" : "not ok 15\n"; - -$refhash{"top"}->{"foo"} = "FOO"; -$refhash{"top"}->{"bar"} = "BAR"; - -delete $refhash{"top"}->{"bar"}; -@list = keys %{$refhash{"top"}}; - -print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; - -{ - my %a = ('bar', 33); - my($a) = \(values %a); - my $b = \$a{bar}; - my $c = \delete $a{bar}; - - print "not " unless $a == $b && $b == $c; - print "ok 17\n"; -} - -# delete() on array elements - -@foo = (); -$foo[1] = 'a'; -$foo[2] = 'b'; -$foo[3] = 'c'; -$foo[4] = 'd'; -$foo[5] = 'e'; - -$foo = delete $foo[2]; - -if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} -unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} -if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} -if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} -if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} -if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} - -@bar = delete @foo[4,5]; - -if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} -if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} -if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} -unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} -unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} -if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} -if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} - -$foo = join('',@foo); -if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} - -if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} - -foreach $key (0 .. $#foo) { - delete $foo[$key]; -} - -if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} - -$foo[0] = 'x'; -$foo[1] = 'y'; - -$foo = "@foo"; -print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; - -$refary[0]->[0] = "FOO"; -$refary[0]->[3] = "BAR"; - -delete $refary[0]->[3]; - -print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; - -{ - my @a = 33; - my($a) = \(@a); - my $b = \$a[0]; - my $c = \delete $a[bar]; - - print "not " unless $a == $b && $b == $c; - print "ok 36\n"; -} diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t deleted file mode 100755 index cf4f8b0..0000000 --- a/contrib/perl5/t/op/die.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl - -print "1..10\n"; - -$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; - -$err = "#[\000]\nok 1\n"; -eval { - die $err; -}; - -print "not " unless $@ eq $err; -print "ok 2\n"; - -$x = [3]; -eval { die $x; }; - -print "not " unless $x->[0] == 4; -print "ok 4\n"; - -eval { - eval { - die [ 5 ]; - }; - die if $@; -}; - -eval { - eval { - die bless [ 7 ], "Error"; - }; - die if $@; -}; - -print "not " unless ref($@) eq "Out"; -print "ok 10\n"; - -package Error; - -sub PROPAGATE { - print "ok ",$_[0]->[0]++,"\n"; - bless [$_[0]->[0]], "Out"; -} diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t deleted file mode 100755 index a389946..0000000 --- a/contrib/perl5/t/op/die_exit.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -# -# Verify that C<die> return the return code -# -- Robin Barker <rmb@cise.npl.co.uk> -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ($^O eq 'mpeix') { - print "1..0 # Skip: broken on MPE/iX\n"; - exit 0; -} - -my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; - -use strict; - -my %tests = ( - 1 => [ 0, 0], - 2 => [ 0, 1], - 3 => [ 0, 127], - 4 => [ 0, 128], - 5 => [ 0, 255], - 6 => [ 0, 256], - 7 => [ 0, 512], - 8 => [ 1, 0], - 9 => [ 1, 1], - 10 => [ 1, 256], - 11 => [ 128, 0], - 12 => [ 128, 1], - 13 => [ 128, 256], - 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; - -print "1..$max\n"; - -foreach my $test (1 .. $max) { - my($bang, $query, $code) = @{$tests{$test}}; - $code ||= 'die;'; - my $exit = - ($^O eq 'MSWin32' - ? 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\n", $exit, $bang, $query; - print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); - print "ok $test\n"; -} - diff --git a/contrib/perl5/t/op/do.t b/contrib/perl5/t/op/do.t deleted file mode 100755 index 87ec08d..0000000 --- a/contrib/perl5/t/op/do.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl - -# $RCSfile: do.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:45 $ - -sub foo1 -{ - print $_[0]; - 'value'; -} - -sub foo2 -{ - shift; - print $_[0]; - $x = 'value'; - $x; -} - -print "1..15\n"; - -$_[0] = "not ok 1\n"; -$result = do foo1("ok 1\n"); -print "#2\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; } -if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; } - -$_[0] = "not ok 4\n"; -$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n"); -print "#5\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; } -if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; } - -$result = do{print "ok 7\n"; 'value';}; -print "#8\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; } - -sub blather { - print @_; -} - -do blather("ok 9\n","ok 10\n"); -@x = ("ok 11\n", "ok 12\n"); -@y = ("ok 14\n", "ok 15\n"); -do blather(@x,"ok 13\n",@y); diff --git a/contrib/perl5/t/op/each.t b/contrib/perl5/t/op/each.t deleted file mode 100755 index 879c0d0..0000000 --- a/contrib/perl5/t/op/each.t +++ /dev/null @@ -1,133 +0,0 @@ -#!./perl - -print "1..19\n"; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -@keys = keys %h; -@values = values %h; - -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] - && (('a' lt 'A' && $key lt $value) || $key gt $value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";} - -$size = ((split('/',scalar %h))[1]); -keys %h = $size * 5; -$newsize = ((split('/',scalar %h))[1]); -if ($newsize == $size * 8) {print "ok 4\n";} else {print "not ok 4\n";} -keys %h = 1; -$size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 5\n";} else {print "not ok 5\n";} -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 6\n";} else {print "not ok 6\n";} -undef %h; -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -if ($size == 8) {print "ok 7\n";} else {print "not ok 7\n";} - -# test scalar each -%hash = 1..20; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar each is bad.\nnot " unless $total == 100; -print "ok 8\n"; - -for (1..3) { @foo = each %hash } -keys %hash; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar keys isn't resetting the iterator.\nnot " if $total != 100; -print "ok 9\n"; - -for (1..3) { @foo = each %hash } -$total = 0; -$total += $key while $key = each %hash; -print "# Iterator of each isn't being maintained.\nnot " if $total == 100; -print "ok 10\n"; - -for (1..3) { @foo = each %hash } -values %hash; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar values isn't resetting the iterator.\nnot " if $total != 100; -print "ok 11\n"; - -$size = (split('/', scalar %hash))[1]; -keys(%hash) = $size / 2; -print "not " if $size != (split('/', scalar %hash))[1]; -print "ok 12\n"; -keys(%hash) = $size + 100; -print "not " if $size == (split('/', scalar %hash))[1]; -print "ok 13\n"; - -print "not " if keys(%hash) != 10; -print "ok 14\n"; - -print keys(hash) != 10 ? "not ok 15\n" : "ok 15\n"; - -$i = 0; -%h = (a => A, b => B, c=> C, d => D, abc => ABC); -@keys = keys(h); -@values = values(h); -while (($key, $value) = each(h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $i++; - } -} -if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } - -{ - package Obj; - sub DESTROY { print "ok 18\n"; } - { - my $h = { A => bless [], __PACKAGE__ }; - while (my($k,$v) = each %$h) { - print "ok 17\n" if $k eq 'A' and ref($v) eq 'Obj'; - } - } - print "ok 19\n"; -} - diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t deleted file mode 100755 index 1838923..0000000 --- a/contrib/perl5/t/op/eval.t +++ /dev/null @@ -1,208 +0,0 @@ -#!./perl - -print "1..40\n"; - -eval 'print "ok 1\n";'; - -if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";} - -eval "\$foo\n = # this is a comment\n'ok 3';"; -print $foo,"\n"; - -eval "\$foo\n = # this is a comment\n'ok 4\n';"; -print $foo; - -print eval ' -$foo =;'; # this tests for a call through yyerror() -if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";} - -print eval '$foo = /'; # this tests for a call through fatal() -if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";} - -print eval '"ok 7\n";'; - -# calculate a factorial with recursive evals - -$foo = 5; -$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; -$ans = eval $fact; -if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";} - -$foo = 5; -$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; -$ans = eval $fact; -if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";} - -open(try,'>Op.eval'); -print try 'print "ok 10\n"; unlink "Op.eval";',"\n"; -close try; - -do 'Op.eval'; print $@; - -# Test the singlequoted eval optimizer - -$i = 11; -for (1..3) { - eval 'print "ok ", $i++, "\n"'; -} - -eval { - print "ok 14\n"; - die "ok 16\n"; - 1; -} || print "ok 15\n$@"; - -# check whether eval EXPR determines value of EXPR correctly - -{ - my @a = qw(a b c d); - my @b = eval @a; - print "@b" eq '4' ? "ok 17\n" : "not ok 17\n"; - print $@ ? "not ok 18\n" : "ok 18\n"; - - my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; - my $b; - @a = eval $a; - print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n"; - print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n"; - $_ = eval $a; - print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n"; - eval $a; - print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n"; - - $b = 'wrong'; - $x = sub { - my $b = "right"; - print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n"; - }; - &$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 $@; - -# does scalar eval"" pop stack correctly? -{ - my $c = eval "(1,2)x10"; - print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; - $x++; -} - -# return from eval {} should clear $@ correctly -{ - my $status = eval { - eval { die }; - print "# eval { return } test\n"; - return; # removing this changes behavior - }; - print "not " if $@; - print "ok $x\n"; - $x++; -} - -# ditto for eval "" -{ - my $status = eval q{ - eval q{ die }; - print "# eval q{ return } test\n"; - return; # removing this changes behavior - }; - print "not " if $@; - print "ok $x\n"; - $x++; -} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t deleted file mode 100755 index 23e9ec1..0000000 --- a/contrib/perl5/t/op/exec.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl - -$| = 1; # flush stdout - -$ENV{LC_ALL} = 'C'; # Forge English error messages. -$ENV{LANGUAGE} = 'C'; # Ditto in GNU. - -if ($^O eq 'MSWin32') { - # XXX the system tests could be written to use ./perl and so work on Win32 - print "1..0 # Skip: shh, win32\n"; - exit(0); -} - -print "1..8\n"; - -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 - -# these should probably be rewritten to match the examples in perlfunc.pod -if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} - -if ($^O eq 'mpeix') { - print "ok 5 # skipped: status broken on MPE/iX\n"; -} else { - if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } - print "ok 5\n"; -} - -$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";} - -exec "echo","ok","8"; diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t deleted file mode 100755 index d4aa292..0000000 --- a/contrib/perl5/t/op/exists_sub.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..9\n"; - -sub t1; -sub t2 : locked; -sub t3 (); -sub t4 ($); -sub t5 {1;} -{ - package P1; - sub tmc {1;} - package P2; - @ISA = 'P1'; -} - -print "not " unless exists &t1 && not defined &t1; -print "ok 1\n"; -print "not " unless exists &t2 && not defined &t2; -print "ok 2\n"; -print "not " unless exists &t3 && not defined &t3; -print "ok 3\n"; -print "not " unless exists &t4 && not defined &t4; -print "ok 4\n"; -print "not " unless exists &t5 && defined &t5; -print "ok 5\n"; -P2::->tmc; -print "not " unless not exists &P2::tmc && not defined &P2::tmc; -print "ok 6\n"; -my $ref; -$ref->{A}[0] = \&t4; -print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; -print "ok 7\n"; -undef &P1::tmc; -print "not " unless exists &P1::tmc && not defined &P1::tmc; -print "ok 8\n"; -eval 'exists &t5()'; -print "not " unless $@; -print "ok 9\n"; - -exit 0; diff --git a/contrib/perl5/t/op/exp.t b/contrib/perl5/t/op/exp.t deleted file mode 100755 index 5efc9ba..0000000 --- a/contrib/perl5/t/op/exp.t +++ /dev/null @@ -1,27 +0,0 @@ -#!./perl - -# $RCSfile: exp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:50 $ - -print "1..6\n"; - -# compile time evaluation - -$s = sqrt(2); -if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";} - -$s = exp(1); -if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} - -if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} - -# run time evaluation - -$x1 = 1; -$x2 = 2; -$s = sqrt($x2); -if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} - -$s = exp($x1); -if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";} - -if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/fh.t b/contrib/perl5/t/op/fh.t deleted file mode 100755 index 86e405a..0000000 --- a/contrib/perl5/t/op/fh.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -print "1..5\n"; - -my $test = 0; - -# symbolic filehandles should only result in glob entries with FH constructors - -$|=1; -my $a = "SYM000"; -print "not " if defined(fileno($a)) or defined *{$a}; -++$test; print "ok $test\n"; - -select select $a; -print "not " unless defined *{$a}; -++$test; print "ok $test\n"; - -$a++; -print "not " if close $a or defined *{$a}; -++$test; print "ok $test\n"; - -print "not " unless open($a, ">&STDOUT") and defined *{$a}; -++$test; print $a "ok $test\n"; - -print "not " unless close $a; -++$test; print $a "not "; print "ok $test\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t deleted file mode 100755 index f757c79..0000000 --- a/contrib/perl5/t/op/filetest.t +++ /dev/null @@ -1,71 +0,0 @@ -#!./perl - -# There are few filetest operators that are portable enough to test. -# See pod/perlport.pod for details. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; -print "1..10\n"; - -print "not " unless -d 'op'; -print "ok 1\n"; - -print "not " unless -f 'TEST'; -print "ok 2\n"; - -print "not " if -f 'op'; -print "ok 3\n"; - -print "not " if -d 'TEST'; -print "ok 4\n"; - -print "not " unless -r 'TEST'; -print "ok 5\n"; - -# make sure TEST is r-x -eval { chmod 0555, 'TEST' }; -$bad_chmod = $@; - -$oldeuid = $>; # root can read and write anything -eval '$> = 1'; # so switch uid (may not be implemented) - -print "# oldeuid = $oldeuid, euid = $>\n"; - -if (!$Config{d_seteuid}) { - print "ok 6 #skipped, no seteuid\n"; -} -elsif ($bad_chmod) { - print "#[$@]\nok 6 #skipped\n"; -} -else { - print "not " if -w 'TEST'; - print "ok 6\n"; -} - -# Scripts are not -x everywhere so cannot test that. - -eval '$> = $oldeuid'; # switch uid back (may not be implemented) - -# this would fail for the euid 1 -# (unless we have unpacked the source code as uid 1...) -print "not " unless -r 'op'; -print "ok 7\n"; - -# this would fail for the euid 1 -# (unless we have unpacked the source code as uid 1...) -if ($Config{d_seteuid}) { - print "not " unless -w 'op'; - print "ok 8\n"; -} else { - print "ok 8 #skipped, no seteuid\n"; -} - -print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? -print "ok 9\n"; - -print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op"; -print "ok 10\n"; diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t deleted file mode 100755 index 99b22ef..0000000 --- a/contrib/perl5/t/op/flip.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ - -print "1..10\n"; - -@a = (1,2,3,4,5,6,7,8,9,10,11,12); - -while ($_ = shift(@a)) { - if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; } - $y .= /1/../2/; -} - -if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";} - -if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} - -@a = ('a','b','c','d','e','f','g'); - -open(of,'harness') or die "Can't open harness: $!"; -while (<of>) { - (3 .. 5) && ($foo .= $_); -} -$x = ($foo =~ y/\n/\n/); - -if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} - -$x = 3.14; -if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";} - -{ - # coredump reported in bug 20001018.008 - readline(UNKNOWN); - $. = 1; - print "ok 10\n" unless 1 .. 10; -} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t deleted file mode 100755 index 88b6b4b..0000000 --- a/contrib/perl5/t/op/fork.t +++ /dev/null @@ -1,423 +0,0 @@ -#!./perl - -# tests for both real and emulated fork() - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - unless ($Config{'d_fork'} - or ($^O eq 'MSWin32' and $Config{useithreads} - and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) - { - print "1..0 # Skip: no fork\n"; - exit 0; - } - $ENV{PERL5LIB} = "../lib"; -} - -if ($^O eq 'mpeix') { - print "1..0 # Skip: fork/status problems on MPE/iX\n"; - exit 0; -} - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "forktmp000"; -1 while -f ++$tmpfile; -END { close TEST; unlink $tmpfile if $tmpfile; } - -$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); - -for (@prgs){ - my $switch; - if (s/^\s*(-\w.*)//){ - $switch = $1; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - $expected =~ s/\n+$//; - # results can be in any order, so sort 'em - my @expected = sort split /\n/, $expected; - open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; - print TEST $prog, "\n"; - close TEST or die "Cannot close $tmpfile: $!"; - my $results; - if ($^O eq 'MSWin32') { - $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; - } - else { - $results = `./perl $switch $tmpfile 2>&1`; - } - $status = $?; - $results =~ s/\n+$//; - $results =~ s/at\s+forktmp\d+\s+line/at - line/g; - $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; -# bison says 'parse error' instead of 'syntax error', -# various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - $results =~ s/^\n*Process terminated by SIG\w+\n?//mg - if $^O eq 'os2'; - my @results = sort split /\n/, $results; - if ( "@results" ne "@expected" ) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ -$| = 1; -if ($cid = fork) { - sleep 1; - if ($result = (kill 9, $cid)) { - print "ok 2\n"; - } - else { - print "not ok 2 $result\n"; - } - sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug -} -else { - print "ok 1\n"; - sleep 10; -} -EXPECT -ok 1 -ok 2 -######## -$| = 1; -sub forkit { - print "iteration $i start\n"; - my $x = fork; - if (defined $x) { - if ($x) { - print "iteration $i parent\n"; - } - else { - print "iteration $i child\n"; - } - } - else { - print "pid $$ failed to fork\n"; - } -} -while ($i++ < 3) { do { forkit(); }; } -EXPECT -iteration 1 start -iteration 1 parent -iteration 1 child -iteration 2 start -iteration 2 parent -iteration 2 child -iteration 2 start -iteration 2 parent -iteration 2 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -######## -$| = 1; -fork() - ? (print("parent\n"),sleep(1)) - : (print("child\n"),exit) ; -EXPECT -parent -child -######## -$| = 1; -fork() - ? (print("parent\n"),exit) - : (print("child\n"),sleep(1)) ; -EXPECT -parent -child -######## -$| = 1; -@a = (1..3); -for (@a) { - if (fork) { - print "parent $_\n"; - $_ = "[$_]"; - } - else { - print "child $_\n"; - $_ = "-$_-"; - } -} -print "@a\n"; -EXPECT -parent 1 -child 1 -parent 2 -child 2 -parent 2 -child 2 -parent 3 -child 3 -parent 3 -child 3 -parent 3 -child 3 -parent 3 -child 3 -[1] [2] [3] --1- [2] [3] -[1] -2- [3] -[1] [2] -3- --1- -2- [3] --1- [2] -3- -[1] -2- -3- --1- -2- -3- -######## -$| = 1; -foreach my $c (1,2,3) { - if (fork) { - print "parent $c\n"; - } - else { - print "child $c\n"; - exit; - } -} -while (wait() != -1) { print "waited\n" } -EXPECT -child 1 -child 2 -child 3 -parent 1 -parent 2 -parent 3 -waited -waited -waited -######## -use Config; -$| = 1; -$\ = "\n"; -fork() - ? print($Config{osname} eq $^O) - : print($Config{osname} eq $^O) ; -EXPECT -1 -1 -######## -$| = 1; -$\ = "\n"; -fork() - ? do { require Config; print($Config::Config{osname} eq $^O); } - : do { require Config; print($Config::Config{osname} eq $^O); } -EXPECT -1 -1 -######## -$| = 1; -use Cwd; -$\ = "\n"; -my $dir; -if (fork) { - $dir = "f$$.tst"; - mkdir $dir, 0755; - chdir $dir; - print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; - chdir ".."; - rmdir $dir; -} -else { - sleep 2; - $dir = "f$$.tst"; - mkdir $dir, 0755; - chdir $dir; - print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; - chdir ".."; - rmdir $dir; -} -EXPECT -ok 1 parent -ok 1 child -######## -$| = 1; -$\ = "\n"; -my $getenv; -if ($^O eq 'MSWin32') { - $getenv = qq[$^X -e "print \$ENV{TST}"]; -} -else { - $getenv = qq[$^X -e 'print \$ENV{TST}']; -} -$ENV{TST} = 'foo'; -if (fork) { - sleep 1; - print "parent before: " . `$getenv`; - $ENV{TST} = 'bar'; - print "parent after: " . `$getenv`; -} -else { - print "child before: " . `$getenv`; - $ENV{TST} = 'baz'; - print "child after: " . `$getenv`; -} -EXPECT -child before: foo -child after: baz -parent before: foo -parent after: bar -######## -$| = 1; -$\ = "\n"; -if ($pid = fork) { - waitpid($pid,0); - print "parent got $?" -} -else { - exit(42); -} -EXPECT -parent got 10752 -######## -$| = 1; -$\ = "\n"; -my $echo = 'echo'; -if ($pid = fork) { - waitpid($pid,0); - print "parent got $?" -} -else { - exec("$echo foo"); -} -EXPECT -foo -parent got 0 -######## -if (fork) { - die "parent died"; -} -else { - die "child died"; -} -EXPECT -parent died at - line 2. -child died at - line 5. -######## -if ($pid = fork) { - eval { die "parent died" }; - print $@; -} -else { - eval { die "child died" }; - print $@; -} -EXPECT -parent died at - line 2. -child died at - line 6. -######## -if (eval q{$pid = fork}) { - eval q{ die "parent died" }; - print $@; -} -else { - eval q{ die "child died" }; - print $@; -} -EXPECT -parent died at (eval 2) line 1. -child died at (eval 2) line 1. -######## -BEGIN { - $| = 1; - fork and exit; - print "inner\n"; -} -# XXX In emulated fork(), the child will not execute anything after -# the BEGIN block, due to difficulties in recreating the parse stacks -# and restarting yyparse() midstream in the child. This can potentially -# be overcome by treating what's after the BEGIN{} as a brand new parse. -#print "outer\n" -EXPECT -inner -######## -sub pipe_to_fork ($$) { - my $parent = shift; - my $child = shift; - pipe($child, $parent) or die; - my $pid = fork(); - die "fork() failed: $!" unless defined $pid; - close($pid ? $child : $parent); - $pid; -} - -if (pipe_to_fork('PARENT','CHILD')) { - # parent - print PARENT "pipe_to_fork\n"; - close PARENT; -} -else { - # child - while (<CHILD>) { print; } - close CHILD; - exit; -} - -sub pipe_from_fork ($$) { - my $parent = shift; - my $child = shift; - pipe($parent, $child) or die; - my $pid = fork(); - die "fork() failed: $!" unless defined $pid; - close($pid ? $child : $parent); - $pid; -} - -if (pipe_from_fork('PARENT','CHILD')) { - # parent - while (<PARENT>) { print; } - close PARENT; -} -else { - # child - print CHILD "pipe_from_fork\n"; - close CHILD; - exit; -} -EXPECT -pipe_from_fork -pipe_to_fork -######## -$|=1; -if ($pid = fork()) { - print "forked first kid\n"; - print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; -} -else { - print "first child\n"; - exit(0); -} -if ($pid = fork()) { - print "forked second kid\n"; - print "wait() returned ok\n" if wait() == $pid; -} -else { - print "second child\n"; - exit(0); -} -EXPECT -forked first kid -first child -waitpid() returned ok -forked second kid -second child -wait() returned ok diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t deleted file mode 100755 index fc0ba77..0000000 --- a/contrib/perl5/t/op/glob.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..6\n"; - -@oops = @ops = <op/*>; - -if ($^O eq 'MSWin32') { - map { $files{lc($_)}++ } <op/*>; - map { delete $files{"op/$_"} } split /[\s\n]/, `cmd /c "dir /b /l op & dir /b /l /ah op 2>nul"`, -} -else { - map { $files{$_}++ } <op/*>; - map { delete $files{$_} } split /[\s\n]/, `echo op/*`; -} -if (keys %files) { - print "not ok 1\t(",join(' ', sort keys %files),"\n"; -} else { print "ok 1\n"; } - -print $/ eq "\n" ? "ok 2\n" : "not ok 2\n"; - -while (<jskdfjskdfj* op/* jskdjfjkosvk*>) { - $not = "not " unless $_ eq shift @ops; - $not = "not at all " if $/ eq "\0"; -} -print "${not}ok 3\n"; - -print $/ eq "\n" ? "ok 4\n" : "not ok 4\n"; - -# test the "glob" operator -$_ = "op/*"; -@glops = glob $_; -print "@glops" eq "@oops" ? "ok 5\n" : "not ok 5\n"; - -@glops = glob; -print "@glops" eq "@oops" ? "ok 6\n" : "not ok 6\n"; diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t deleted file mode 100755 index 96bb8dd..0000000 --- a/contrib/perl5/t/op/goto.t +++ /dev/null @@ -1,126 +0,0 @@ -#!./perl - -# "This IS structured code. It's just randomly structured." - -print "1..16\n"; - -while ($?) { - $foo = 1; - label1: - $foo = 2; - goto label2; -} continue { - $foo = 0; - goto label4; - label3: - $foo = 4; - goto label4; -} -goto label1; - -$foo = 3; - -label2: -print "#1\t:$foo: == 2\n"; -if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";} -goto label3; - -label4: -print "#2\t:$foo: == 4\n"; -if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} - -$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$CMD = qq[$PERL -e "goto foo;" 2>&1 ]; -$x = `$CMD`; - -if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} - -sub foo { - goto bar; - print "not ok 4\n"; - return; -bar: - print "ok 4\n"; -} - -&foo; - -sub bar { - $x = 'bypass'; - eval "goto $x"; -} - -&bar; -exit; - -FINALE: -print "ok 13\n"; - -# does goto LABEL handle block contexts correctly? - -my $cond = 1; -for (1) { - if ($cond == 1) { - $cond = 0; - goto OTHER; - } - elsif ($cond == 0) { - OTHER: - $cond = 2; - print "ok 14\n"; - goto THIRD; - } - else { - THIRD: - print "ok 15\n"; - } -} -print "ok 16\n"; -exit; - -bypass: -print "ok 5\n"; - -# Test autoloading mechanism. - -sub two { - ($pack, $file, $line) = caller; # Should indicate original call stats. - print "@_ $pack $file $line" eq "1 2 3 main $FILE $LINE" - ? "ok 7\n" - : "not ok 7\n"; -} - -sub one { - eval <<'END'; - sub one { print "ok 6\n"; goto &two; print "not ok 6\n"; } -END - goto &one; -} - -$FILE = __FILE__; -$LINE = __LINE__ + 1; -&one(1,2,3); - -$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/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t deleted file mode 100755 index cf2cafd..0000000 --- a/contrib/perl5/t/op/goto_xs.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl -# tests for "goto &sub"-ing into XSUBs - -# $RCSfile$$Revision$$Date$ - -# Note: This only tests things that should *work*. At some point, it may -# be worth while to write some failure tests for things that should -# *break* (such as calls with wrong number of args). For now, I'm -# guessing that if all of these work correctly, the bad ones will -# break correctly as well. - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -# turn warnings into fatal errors -$SIG{__WARN__} = sub { die "WARNING: @_" } ; - -BEGIN { $| = 1; } -eval 'require Fcntl' - or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 }; - -print "1..10\n"; - -# We don't know what symbols are defined in platform X's system headers. -# We don't even want to guess, because some platform out there will -# likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0) -# should always return a value, even on platforms which don't define the -# cpp symbol; Fcntl.xs says: -# /* We support flock() on systems which don't have it, so -# always supply the constants. */ -# If this ceases to be the case, we're in trouble. =) -$VALID = 'LOCK_SH'; - -### First, we check whether Fcntl::constant returns sane answers. -# Fcntl::constant("LOCK_SH",0) should always succeed. - -$value = Fcntl::constant($VALID,0); -print((!defined $value) - ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" - : "ok 1\n"); - -### OK, we're ready to do real tests. - -# test "goto &function_constant" -sub goto_const { goto &Fcntl::constant; } - -$ret = goto_const($VALID,0); -print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); - -# test "goto &$function_package_and_name" -$FNAME1 = 'Fcntl::constant'; -sub goto_name1 { goto &$FNAME1; } - -$ret = goto_name1($VALID,0); -print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); - -# test "goto &$function_package_and_name" again, with dirtier stack -$ret = goto_name1($VALID,0); -print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); -$ret = goto_name1($VALID,0); -print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); - -# test "goto &$function_name" from local package -package Fcntl; -$FNAME2 = 'constant'; -sub goto_name2 { goto &$FNAME2; } -package main; - -$ret = Fcntl::goto_name2($VALID,0); -print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); - -# test "goto &$function_ref" -$FREF = \&Fcntl::constant; -sub goto_ref { goto &$FREF; } - -$ret = goto_ref($VALID,0); -print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); - -### tests where the args are not on stack but in GvAV(defgv) (ie, @_) - -# test "goto &function_constant" from a sub called without arglist -sub call_goto_const { &goto_const; } - -$ret = call_goto_const($VALID,0); -print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); - -# test "goto &$function_package_and_name" from a sub called without arglist -sub call_goto_name1 { &goto_name1; } - -$ret = call_goto_name1($VALID,0); -print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); - -# test "goto &$function_ref" from a sub called without arglist -sub call_goto_ref { &goto_ref; } - -$ret = call_goto_ref($VALID,0); -print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t deleted file mode 100755 index 211dc91..0000000 --- a/contrib/perl5/t/op/grent.t +++ /dev/null @@ -1,168 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../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 the GR filehandle should be open and full of juicy group entries. - -print "1..2\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; - -setgrent(); -while (<GR>) { - chomp; - # LIMIT -1 so that groups with no users don't fall off - my @s = split /:/, $_, -1; - my ($name_s,$passwd_s,$gid_s,$members_s) = @s; - if (@s) { - push @{ $seen{$name_s} }, $.; - } 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++; -} - -endgrent(); - -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"; - -# Test both the scalar and list contexts. - -my @gr1; - -setgrent(); -for (1..$max) { - my $gr = scalar getgrent(); - last unless defined $gr; - push @gr1, $gr; -} -endgrent(); - -my @gr2; - -setgrent(); -for (1..$max) { - my ($gr) = (getgrent()); - last unless defined $gr; - push @gr2, $gr; -} -endgrent(); - -print "not " unless "@gr1" eq "@gr2"; -print "ok ", $tst++, "\n"; - -close(GR); diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t deleted file mode 100755 index 3a7f8ad..0000000 --- a/contrib/perl5/t/op/grep.t +++ /dev/null @@ -1,99 +0,0 @@ -#!./perl - -# -# grep() and map() tests -# - -print "1..27\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++; -} - -{ - print map({$_} ("ok $test\n")); - $test++; - print map - ({$_} ("ok $test\n")); - $test++; - print((map({a => $_}, ("ok $test\n")))[0]->{a}); - $test++; - print((map - ({a=>$_}, - ("ok $test\n")))[0]->{a}); - $test++; - print map { $_ } ("ok $test\n"); - $test++; - print map - { $_ } ("ok $test\n"); - $test++; - print((map {a => $_}, ("ok $test\n"))[0]->{a}); - $test++; - print((map - {a=>$_}, - ("ok $test\n"))[0]->{a}); - $test++; - my $x = "ok \xFF\xFF\n"; - print map($_&$x,("ok $test\n")); - $test++; - print map - ($_ & $x, ("ok $test\n")); - $test++; - print map { $_ & $x } ("ok $test\n"); - $test++; - print map - { $_&$x } ("ok $test\n"); - $test++; - - print grep({$_} ("ok $test\n")); - $test++; - print grep - ({$_} ("ok $test\n")); - $test++; - print grep({a => $_}->{a}, ("ok $test\n")); - $test++; - print grep - ({a => $_}->{a}, - ("ok $test\n")); - $test++; - print grep { $_ } ("ok $test\n"); - $test++; - print grep - { $_ } ("ok $test\n"); - $test++; - print grep {a => $_}->{a}, ("ok $test\n"); - $test++; - print grep - {a => $_}->{a}, - ("ok $test\n"); - $test++; - print grep($_&"X",("ok $test\n")); - $test++; - print grep - ($_&"X", ("ok $test\n")); - $test++; - print grep { $_ & "X" } ("ok $test\n"); - $test++; - print grep - { $_ & "X" } ("ok $test\n"); - $test++; -} diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t deleted file mode 100755 index 082d2d1..0000000 --- a/contrib/perl5/t/op/groups.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl - -$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . - exists $ENV{PATH} ? ":$ENV{PATH}" : ""; -$ENV{LC_ALL} = "C"; # so that external utilities speak English -$ENV{LANGUAGE} = 'C'; # GNU locale extension - -sub quit { - print "1..0 # Skip: no `id` or `groups`\n"; - exit 0; -} - -quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i; - -# We have to find a command that prints all (effective -# and real) group names (not ids). The known commands are: -# groups -# id -Gn -# id -a -# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. -# Beware 2: id -Gn or id -a format might be id(name) or name(id). -# Beware 3: the groups= might be anywhere in the id output. -# Beware 4: groups can have spaces ('id -a' being the only defense against this) -# Beware 5: id -a might not contain the groups= part. -# -# That is, we might meet the following: -# -# foo bar zot # accept -# foo 22 42 bar zot # accept -# 1 22 42 2 3 # reject -# groups=(42),foo(1),bar(2),zot me(3) # parse -# groups=22,42,1(foo),2(bar),3(zot me) # parse -# -# and the groups= might be after, before, or between uid=... and gid=... - -GROUPS: { - # prefer 'id' over 'groups' (is this ever wrong anywhere?) - # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) - if (($groups = `id -a 2>/dev/null`) ne '') { - # $groups is of the form: - # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) - last GROUPS if $groups =~ /groups=/; - } - if (($groups = `id -Gn 2>/dev/null`) ne '') { - # $groups could be of the form: - # users 33536 39181 root dev - last GROUPS if $groups !~ /^(\d|\s)+$/; - } - if (($groups = `groups 2>/dev/null`) ne '') { - # may not reflect all groups in some places, so do a sanity check - if (-d '/afs') { - print <<EOM; -# These test results *may* be bogus, as you appear to have AFS, -# and I can't find a working 'id' in your PATH (which I have set -# to '$ENV{PATH}'). -# -# If these tests fail, report the particular incantation you use -# on this platform to find *all* the groups that an arbitrary -# luser may belong to, using the 'perlbug' program. -EOM - } - last GROUPS; - } - # Okay, not today. - quit(); -} - -unless (eval { getgrgid(0); 1 }) { - print "1..0 # Skip: getgrgid() not implemented\n"; - exit 0; -} - -# Remember that group names can contain whitespace, '-', et cetera. -# That is: do not \w, do not \S. -if ($groups =~ /groups=(.+)( [ug]id=|$)/) { - my $gr = $1; - my @g0 = split /,/, $gr; - my @g1; - # prefer names over numbers - for (@g0) { - # 42(zot me) - if (/^(\d+)(?:\(([^)]+)\))?/) { - push @g1, ($2 || $1); - } - # zot me(42) - elsif (/^([^(]*)\((\d+)\)/) { - push @g1, ($1 || $2); - } - else { - print "# ignoring group entry [$_]\n"; - } - } - print "# groups=$gr\n"; - print "# g0 = @g0\n"; - print "# g1 = @g1\n"; - $groups = "@g1"; -} - -print "1..2\n"; - -$pwgid = $( + 0; -($pwgnam) = getgrgid($pwgid); -@basegroup{$pwgid,$pwgnam} = (1,1); - -$seen{$pwgid}++; - -for (split(' ', $()) { - next if $seen{$_}++; - ($group) = getgrgid($_); - if (defined $group) { - push(@gr, $group); - } - else { - push(@gr, $_); - } -} - -if ($^O =~ /^(?:uwin|solaris)$/) { - # Or anybody else who can have spaces in group names. - $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); -} else { - $gr1 = join(' ', sort @gr); -} - -$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); - -if ($gr1 eq $gr2) { - print "ok 1\n"; -} -else { - print "#gr1 is <$gr1>\n"; - print "#gr2 is <$gr2>\n"; - print "not ok 1\n"; -} - -# multiple 0's indicate GROUPSTYPE is currently long but should be short - -if ($pwgid == 0 || $seen{0} < 2) { - print "ok 2\n"; -} -else { - print "not ok 2 (groupstype should be type short, not long)\n"; -} diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t deleted file mode 100755 index 8311244..0000000 --- a/contrib/perl5/t/op/gv.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl - -# -# various typeglob tests -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; - -print "1..40\n"; - -# type coersion on assignment -$foo = 'foo'; -$bar = *main::foo; -$bar = $foo; -print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n"; -$foo = *main::bar; - -# type coersion (not) on misc ops - -if ($foo) { - print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n"; -} - -unless ($foo =~ /abcd/) { - print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n"; -} - -if ($foo eq '*main::bar') { - print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n"; -} - -# type coersion on substitutions that match -$a = *main::foo; -$b = $a; -$a =~ s/^X//; -print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n"; -$a =~ s/^\*//; -print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n"; -print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n"; - -# typeglobs as lvalues -substr($foo, 0, 1) = "XXX"; -print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n"; -print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n"; - -# returning glob values -sub foo { - local($bar) = *main::foo; - $foo = *main::bar; - return ($foo, $bar); -} - -($fuu, $baa) = foo(); -if (defined $fuu) { - print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n"; -} - -if (defined $baa) { - print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; -} - -# nested package globs -# NOTE: It's probably OK if these semantics change, because the -# fact that %X::Y:: is stored in %X:: isn't documented. -# (I hope.) - -{ package Foo::Bar; no warnings 'once'; $test=1; } -print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; -print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; - -# test undef operator clearing out entire glob -$foo = 'stuff'; -@foo = qw(more stuff); -%foo = qw(even more random stuff); -undef *foo; -print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; - -# test warnings from assignment of undef to glob -{ - my $msg; - local $SIG{__WARN__} = sub { $msg = $_[0] }; - use warnings; - *foo = 'bar'; - print $msg ? "not ok" : "ok", " 15\n"; - *foo = undef; - print $msg ? "ok" : "not ok", " 16\n"; -} - -# test *glob{THING} syntax -$x = "ok 17\n"; -@x = ("ok 18\n"); -%x = ("ok 19" => "\n"); -sub x { "ok 20\n" } -print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; -*x = *STDOUT; -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}; -} - -# although it *should* if you're talking about magicals - -{ - my $test = 29; - - my $a = "]"; - print "not " unless defined ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - - $a = "1"; - "o" =~ /(o)/; - print "not " unless ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - $a = "2"; - print "not " if ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - $a = "1x"; - print "not " if defined ${$a}; - ++$test; print "ok $test\n"; - print "not " if defined *{$a}; - ++$test; print "ok $test\n"; - $a = "11"; - "o" =~ /(((((((((((o)))))))))))/; - print "not " unless ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; -} - - -# does pp_readline() handle glob-ness correctly? - -{ - my $g = *foo; - $g = <DATA>; - print $g; -} - -__END__ -ok 40 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t deleted file mode 100755 index 8466a71..0000000 --- a/contrib/perl5/t/op/hashwarn.t +++ /dev/null @@ -1,77 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -use warnings; - -use vars qw{ @warnings }; - -BEGIN { - $SIG{'__WARN__'} = sub { push @warnings, @_ }; - $| = 1; - print "1..9\n"; -} - -END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings } - -sub test ($$;$) { - my($num, $bool, $diag) = @_; - if ($bool) { - print "ok $num\n"; - return; - } - print "not ok $num\n"; - return unless defined $diag; - $diag =~ s/\Z\n?/\n/; # unchomp - print map "# $num : $_", split m/^/m, $diag; -} - -sub test_warning ($$$) { - my($num, $got, $expected) = @_; - my($pattern, $ok); - if (($pattern) = ($expected =~ m#^/(.+)/$#s) or - (undef, $pattern) = ($expected =~ m#^m([^\w\s])(.+)\1$#s)) { - # it's a regexp - $ok = ($got =~ /$pattern/); - test $num, $ok, "Expected pattern /$pattern/, got '$got'\n"; - } else { - $ok = ($got eq $expected); - test $num, $ok, "Expected string '$expected', got '$got'\n"; - } -# print "# $num: $got\n"; -} - -my $odd_msg = '/^Odd number of elements in hash/'; -my $ref_msg = '/^Reference found where even-sized list expected/'; - -{ - my %hash = (1..3); - test_warning 1, shift @warnings, $odd_msg; - - %hash = 1; - test_warning 2, shift @warnings, $odd_msg; - - %hash = { 1..3 }; - test_warning 3, shift @warnings, $odd_msg; - test_warning 4, shift @warnings, $ref_msg; - - %hash = [ 1..3 ]; - test_warning 5, shift @warnings, $ref_msg; - - %hash = sub { print "ok" }; - test_warning 6, shift @warnings, $odd_msg; - - my $avhv = [{x=>1,y=>2}]; - %$avhv = (x=>13,'y'); - test_warning 7, shift @warnings, $odd_msg; - - %$avhv = 'x'; - test_warning 8, shift @warnings, $odd_msg; - - $_ = { 1..10 }; - test 9, ! @warnings, "Unexpected warning"; -} diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t deleted file mode 100755 index f59115e..0000000 --- a/contrib/perl5/t/op/inc.t +++ /dev/null @@ -1,97 +0,0 @@ -#!./perl - -print "1..12\n"; - -# Verify that addition/subtraction properly upgrade to doubles. -# These tests are only significant on machines with 32 bit longs, -# and two's complement negation, but shouldn't fail anywhere. - -$a = 2147483647; -$c=$a++; -if ($a == 2147483648) - {print "ok 1\n"} -else - {print "not ok 1\n";} - -$a = 2147483647; -$c=++$a; -if ($a == 2147483648) - {print "ok 2\n"} -else - {print "not ok 2\n";} - -$a = 2147483647; -$a=$a+1; -if ($a == 2147483648) - {print "ok 3\n"} -else - {print "not ok 3\n";} - -$a = -2147483648; -$c=$a--; -if ($a == -2147483649) - {print "ok 4\n"} -else - {print "not ok 4\n";} - -$a = -2147483648; -$c=--$a; -if ($a == -2147483649) - {print "ok 5\n"} -else - {print "not ok 5\n";} - -$a = -2147483648; -$a=$a-1; -if ($a == -2147483649) - {print "ok 6\n"} -else - {print "not ok 6\n";} - -$a = 2147483648; -$a = -$a; -$c=$a--; -if ($a == -2147483649) - {print "ok 7\n"} -else - {print "not ok 7\n";} - -$a = 2147483648; -$a = -$a; -$c=--$a; -if ($a == -2147483649) - {print "ok 8\n"} -else - {print "not ok 8\n";} - -$a = 2147483648; -$a = -$a; -$a=$a-1; -if ($a == -2147483649) - {print "ok 9\n"} -else - {print "not ok 9\n";} - -$a = 2147483648; -$b = -$a; -$c=$b--; -if ($b == -$a-1) - {print "ok 10\n"} -else - {print "not ok 10\n";} - -$a = 2147483648; -$b = -$a; -$c=--$b; -if ($b == -$a-1) - {print "ok 11\n"} -else - {print "not ok 11\n";} - -$a = 2147483648; -$b = -$a; -$b=$b-1; -if ($b == -(++$a)) - {print "ok 12\n"} -else - {print "not ok 12\n";} diff --git a/contrib/perl5/t/op/index.t b/contrib/perl5/t/op/index.t deleted file mode 100755 index 0b08f08..0000000 --- a/contrib/perl5/t/op/index.t +++ /dev/null @@ -1,42 +0,0 @@ -#!./perl - -# $RCSfile: index.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:59 $ - -print "1..20\n"; - - -$foo = 'Now is the time for all good men to come to the aid of their country.'; - -$first = substr($foo,0,index($foo,'the')); -print ($first eq "Now is " ? "ok 1\n" : "not ok 1\n"); - -$last = substr($foo,rindex($foo,'the'),100); -print ($last eq "their country." ? "ok 2\n" : "not ok 2\n"); - -$last = substr($foo,index($foo,'Now'),2); -print ($last eq "No" ? "ok 3\n" : "not ok 3\n"); - -$last = substr($foo,rindex($foo,'Now'),2); -print ($last eq "No" ? "ok 4\n" : "not ok 4\n"); - -$last = substr($foo,index($foo,'.'),100); -print ($last eq "." ? "ok 5\n" : "not ok 5\n"); - -$last = substr($foo,rindex($foo,'.'),100); -print ($last eq "." ? "ok 6\n" : "not ok 6\n"); - -print index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n"; -print index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n"; -print index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n"; -print index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n"; -print index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n"; -print index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n"; -print index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n"; - -print rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n"; -print rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n"; -print rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n"; -print rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n"; -print rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n"; -print rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n"; -print rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n"; diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t deleted file mode 100755 index 7d675a4..0000000 --- a/contrib/perl5/t/op/int.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..7\n"; - -# compile time evaluation - -if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";} - -if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} - -# run time evaluation - -$x = 1.234; -if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} -if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} - -$x = length("abc") % -10; -print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; - -{ - use integer; - $x = length("abc") % -10; - $y = (3/-10)*-10; - print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; -} - -# check bad strings still get converted - -@x = ( 6, 8, 10); -print "not " if $x["1foo"] != 8; -print "ok 7\n"; diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t deleted file mode 100755 index 0f849fd..0000000 --- a/contrib/perl5/t/op/join.t +++ /dev/null @@ -1,67 +0,0 @@ -#!./perl - -print "1..14\n"; - -@x = (1, 2, 3); -if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} - -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";} - -# 7,8 check for multiple read of tied objects -{ package X; - sub TIESCALAR { my $x = 7; bless \$x }; - sub FETCH { my $y = shift; $$y += 5 }; - tie my $t, 'X'; - my $r = join ':', $t, 99, $t, 99; - print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; - print "ok 7\n"; - $r = join '', $t, 99, $t, 99; - print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; - print "ok 8\n"; -}; - -# 9,10 and for multiple read of undef -{ my $s = 5; - local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); - my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; - print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; - print "ok 9\n"; - my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; - print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; - print "ok 10\n"; -}; - -{ my $s = join("", chr(0x1234), chr(0xff)); - print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; - print "ok 11\n"; -} - -{ my $s = join(chr(0xff), chr(0x1234), ""); - print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; - print "ok 12\n"; -} - -{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); - print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; - print "ok 13\n"; -} - -{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); - print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; - print "ok 14\n"; -} - diff --git a/contrib/perl5/t/op/length.t b/contrib/perl5/t/op/length.t deleted file mode 100755 index ceb005e..0000000 --- a/contrib/perl5/t/op/length.t +++ /dev/null @@ -1,85 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..13\n"; - -print "not " unless length("") == 0; -print "ok 1\n"; - -print "not " unless length("abc") == 3; -print "ok 2\n"; - -$_ = "foobar"; -print "not " unless length() == 6; -print "ok 3\n"; - -# Okay, so that wasn't very challenging. Let's go Unicode. - -{ - my $a = "\x{41}"; - - print "not " unless length($a) == 1; - print "ok 4\n"; - $test++; - - use bytes; - print "not " unless $a eq "\x41" && length($a) == 1; - print "ok 5\n"; - $test++; -} - -{ - my $a = "\x{80}"; - - print "not " unless length($a) == 1; - print "ok 6\n"; - $test++; - - use bytes; - print "not " unless $a eq "\xc2\x80" && length($a) == 2; - print "ok 7\n"; - $test++; -} - -{ - my $a = "\x{100}"; - - print "not " unless length($a) == 1; - print "ok 8\n"; - $test++; - - use bytes; - print "not " unless $a eq "\xc4\x80" && length($a) == 2; - print "ok 9\n"; - $test++; -} - -{ - my $a = "\x{100}\x{80}"; - - print "not " unless length($a) == 2; - print "ok 10\n"; - $test++; - - use bytes; - print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4; - print "ok 11\n"; - $test++; -} - -{ - my $a = "\x{80}\x{100}"; - - print "not " unless length($a) == 2; - print "ok 12\n"; - $test++; - - use bytes; - print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; - print "ok 13\n"; - $test++; -} diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t deleted file mode 100755 index d761f73..0000000 --- a/contrib/perl5/t/op/lex_assign.t +++ /dev/null @@ -1,325 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @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..", (10 + @INPUT + @simple_input), "\n"; -$ord = 0; - -sub wrn {"@_"} - -# Check correct optimization of ucfirst etc -$ord++; -my $a = "AB"; -my $b = "\u\L$a"; -print "not " unless $b eq 'Ab'; -print "ok $ord\n"; - -# Check correct destruction of objects: -my $dc = 0; -sub A::DESTROY {$dc += 1} -$a=8; -my $b; -{ my $c = 6; $b = bless \$c, "A"} - -$ord++; -print "not " unless $dc == 0; -print "ok $ord\n"; - -$b = $a+5; - -$ord++; -print "not " unless $dc == 1; -print "ok $ord\n"; - -$ord++; -my $xxx = 'b'; -$xxx = 'c' . ($xxx || 'e'); -print "not " unless $xxx eq 'cb'; -print "ok $ord\n"; - -{ # Check calling STORE - my $sc = 0; - sub B::TIESCALAR {bless [11], 'B'} - sub B::FETCH { -(shift->[0]) } - sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift } - - my $m; - tie $m, 'B'; - $m = 100; - - $ord++; - print "not " unless $sc == 1; - print "ok $ord\n"; - - my $t = 11; - $m = $t + 89; - - $ord++; - print "not " unless $sc == 2; - print "ok $ord\n"; - - $ord++; - print "# $m\nnot " unless $m == -117; - print "ok $ord\n"; - - $m += $t; - - $ord++; - print "not " unless $sc == 3; - print "ok $ord\n"; - - $ord++; - print "# $m\nnot " unless $m == 89; - print "ok $ord\n"; - -} - -# Chains of assignments - -my ($l1, $l2, $l3, $l4); -my $zzzz = 12; -$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; - -$ord++; -print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " - unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 - and $l2 == 13 and $l3 == 13 and $l4 == 13; -print "ok $ord\n"; - -for (@INPUT) { - $ord++; - ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; - $comment = $op unless defined $comment; - chomp; - $op = "$op==$op" unless $op =~ /==/; - ($op, $expectop) = $op =~ /(.*)==(.*)/; - - $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) - ? "skip" : "# '$_'\nnot"; - $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 "# '$_'\nnot ok $ord\n"; - } - } -} - -for (@simple_input) { - $ord++; - ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; - $comment = $op unless defined $comment; - chomp; - ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; - eval <<EOE; - local \$SIG{__WARN__} = \\&wrn; - 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 "# '$_'\nnot 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) % 2 == 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: can randomly fail -'???' # alarm -'???' # shmget -'???' # shmctl -'???' # shmread -'???' # shmwrite -'???' # msgget -'???' # msgctl -'???' # msgsnd -'???' # msgrcv -'???' # semget -'???' # semctl -'???' # semop -'???' # getlogin -'???' # syscall diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t deleted file mode 100755 index 0a1c399..0000000 --- a/contrib/perl5/t/op/lfs.t +++ /dev/null @@ -1,272 +0,0 @@ -# NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio). -# sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. -# If you modify/add tests here, remember to update also t/lib/syslfs.t. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - # Don't bother if there are no quad offsets. - require Config; import Config; - if ($Config{lseeksize} < 8) { - print "1..0 # Skip: no 64-bit file offsets\n"; - exit(0); - } -} - -use strict; - -our @s; -our $fail; - -sub zap { - close(BIG); - unlink("big"); - unlink("big1"); - unlink("big2"); -} - -sub bye { - zap(); - exit(0); -} - -my $explained; - -sub explain { - unless ($explained++) { - print <<EOM; -# -# If the lfs (large file support: large meaning larger than two -# gigabytes) tests are skipped or fail, it may mean either that your -# process (or process group) is not allowed to write large files -# (resource limits) or that the file system (the network filesystem?) -# you are running the tests on doesn't let your user/group have large -# files (quota) or the filesystem simply doesn't support large files. -# You may even need to reconfigure your kernel. (This is all very -# operating system and site-dependent.) -# -# Perl may still be able to support large files, once you have -# such a process, enough quota, and such a (file) system. -# It is just that the test failed now. -# -EOM - } - print "1..0 # Skip: @_\n" if @_; -} - -print "# checking whether we have sparse files...\n"; - -# Known have-nots. -if ($^O eq 'MSWin32' || $^O eq 'VMS') { - print "1..0 # Skip: no sparse files in $^O\n"; - bye(); -} - -# Known haves that have problems running this test -# (for example because they do not support sparse files, like UNICOS) -if ($^O eq 'unicos') { - print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; - bye(); -} - -# Then try to heuristically deduce whether we have sparse files. - -# Let's not depend on Fcntl or any other extension. - -my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); - -# We'll start off by creating a one megabyte file which has -# only three "true" bytes. If we have sparseness, we should -# consume less blocks than one megabyte (assuming nobody has -# one megabyte blocks...) - -open(BIG, ">big1") or - do { warn "open big1 failed: $!\n"; bye }; -binmode(BIG) or - do { warn "binmode big1 failed: $!\n"; bye }; -seek(BIG, 1_000_000, $SEEK_SET) or - do { warn "seek big1 failed: $!\n"; bye }; -print BIG "big" or - do { warn "print big1 failed: $!\n"; bye }; -close(BIG) or - do { warn "close big1 failed: $!\n"; bye }; - -my @s1 = stat("big1"); - -print "# s1 = @s1\n"; - -open(BIG, ">big2") or - do { warn "open big2 failed: $!\n"; bye }; -binmode(BIG) or - do { warn "binmode big2 failed: $!\n"; bye }; -seek(BIG, 2_000_000, $SEEK_SET) or - do { warn "seek big2 failed; $!\n"; bye }; -print BIG "big" or - do { warn "print big2 failed; $!\n"; bye }; -close(BIG) or - do { warn "close big2 failed; $!\n"; bye }; - -my @s2 = stat("big2"); - -print "# s2 = @s2\n"; - -zap(); - -unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && - $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0 # Skip: no sparse files?\n"; - bye; -} - -print "# we seem to have sparse files...\n"; - -# By now we better be sure that we do have sparse files: -# if we are not, the following will hog 5 gigabytes of disk. Ooops. -# This may fail by producing some signal; run in a subprocess first for safety - -$ENV{LC_ALL} = "C"; - -my $r = system '../perl', '-e', <<'EOF'; -open(BIG, ">big"); -seek(BIG, 5_000_000_000, 0); -print BIG "big"; -exit 0; -EOF - -open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; -binmode BIG; -if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { - my $err = $r ? 'signal '.($r & 0x7f) : $!; - explain("seeking past 2GB failed: $err"); - bye(); -} - -# Either the print or (more likely, thanks to buffering) the close will -# fail if there are are filesize limitations (process or fs). -my $print = print BIG "big"; -print "# print failed: $!\n" unless $print; -my $close = close BIG; -print "# close failed: $!\n" unless $close; -unless ($print && $close) { - if ($! =~/too large/i) { - explain("writing past 2GB failed: process limits?"); - } elsif ($! =~ /quota/i) { - explain("filesystem quota limits?"); - } else { - explain("error: $!"); - } - bye(); -} - -@s = stat("big"); - -print "# @s\n"; - -unless ($s[7] == 5_000_000_003) { - explain("kernel/fs not configured to use large files?"); - bye(); -} - -sub fail () { - print "not "; - $fail++; -} - -sub offset ($$) { - my ($offset_will_be, $offset_want) = @_; - my $offset_is = eval $offset_will_be; - unless ($offset_is == $offset_want) { - print "# bad offset $offset_is, want $offset_want\n"; - my ($offset_func) = ($offset_will_be =~ /^(\w+)/); - if (unpack("L", pack("L", $offset_want)) == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - print "# $offset_want cast into 32 bits equals $offset_is.\n"; - } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 - == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", - $offset_want, - $offset_want, - $offset_is; - } - fail; - } -} - -print "1..17\n"; - -$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"; - -offset('tell(BIG)', 4_500_000_000); -print "ok 6\n"; - -fail unless seek(BIG, 1, $SEEK_CUR); -print "ok 7\n"; - -# If you get 205_032_705 from here it means that -# your tell() is returning 32-bit values since (I32)4_500_000_001 -# is exactly 205_032_705. -offset('tell(BIG)', 4_500_000_001); -print "ok 8\n"; - -fail unless seek(BIG, -1, $SEEK_CUR); -print "ok 9\n"; - -offset('tell(BIG)', 4_500_000_000); -print "ok 10\n"; - -fail unless seek(BIG, -3, $SEEK_END); -print "ok 11\n"; - -offset('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 -# See that we don't have "big" in the 705_... spot: -# that would mean that we have a wraparound. -fail unless seek(BIG, 705_032_704, $SEEK_SET); -print "ok 15\n"; - -my $zero; - -fail unless read(BIG, $zero, 3) == 3; -print "ok 16\n"; - -fail unless $zero eq "\0\0\0"; -print "ok 17\n"; - -explain() if $fail; - -bye(); # does the necessary cleanup - -END { - unlink "big"; # be paranoid about leaving 5 gig files lying around -} - -# eof diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t deleted file mode 100755 index 4d7a2d5..0000000 --- a/contrib/perl5/t/op/list.t +++ /dev/null @@ -1,89 +0,0 @@ -#!./perl - -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";} - -$_ = join(':',@foo); -if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} - -($a,$b,$c,$d) = (1,2,3,4); -if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";} - -($c,$b,$a) = split(/ /,"111 222 333"); -if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";} - -($a,$b,$c) = ($c,$b,$a); -if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";} - -($a, $b) = ($b, $a); -if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";} - -($a, $b[1], $c{2}, $d) = (1, 2, 3, 4); -if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";} -if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";} -if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";} -if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";} - -@foo = (1,2,3,4,5,6,7,8); -($a, $b, $c, $d) = @foo; -print "#11 $a;$b;$c;$d eq 1;2;3;4\n"; -if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";} - -@foo = @bar = (1); -if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";} - -@foo = (); -@foo = 1+2+3; -if (join(':',@foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";} - -for ($x = 0; $x < 3; $x++) { - ($a, $b, $c) = - $x == 0? - ('ok ', 14, "\n"): - $x == 1? - ('ok ', 15, "\n"): - # default - ('ok ', 16, "\n"); - - print $a,$b,$c; -} - -@a = ($x == 12345 || (1,2,3)); -if (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";} - -@a = ($x == $x || (4,5,6)); -if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";} - -if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";} -if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";} -if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";} -if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";} -if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";} -if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";} - -for ($x = 0; $x < 3; $x++) { - ($a, $b, $c) = do { - if ($x == 0) { - ('ok ', 25, "\n"); - } - elsif ($x == 1) { - ('ok ', 26, "\n"); - } - else { - ('ok ', 27, "\n"); - } - }; - - print $a,$b,$c; -} - -# slices -{ - my @a = (0, undef, undef, 3); - my @b = @a[1,2]; - my @c = (0, undef, undef, 3)[1, 2]; - print "not " unless @b == @c and @c == 2; - print "ok 28\n"; -} diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t deleted file mode 100755 index cf606b7..0000000 --- a/contrib/perl5/t/op/local.t +++ /dev/null @@ -1,234 +0,0 @@ -#!./perl - -print "1..69\n"; - -sub foo { - local($a, $b) = @_; - local($c, $d); - $c = "ok 3\n"; - $d = "ok 4\n"; - { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); } - print $a, $b; - $c . $d; -} - -$a = "ok 5\n"; -$b = "ok 6\n"; -$c = "ok 7\n"; -$d = "ok 8\n"; - -print &foo("ok 1\n","ok 2\n"); - -print $a,$b,$c,$d,$x,$y; - -# same thing, only with arrays and associative arrays - -sub foo2 { - local($a, @b) = @_; - local(@c, %d); - @c = "ok 13\n"; - $d{''} = "ok 14\n"; - { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); } - print $a, @b; - $c[0] . $d{''}; -} - -$a = "ok 15\n"; -@b = "ok 16\n"; -@c = "ok 17\n"; -$d{''} = "ok 18\n"; - -print &foo2("ok 11\n","ok 12\n"); - -print $a,@b,@c,%d,$x,$y; - -eval 'local($$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n"; - -eval 'local(@$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; - -eval 'local(%$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; - -# Array and hash elements - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = 'foo'; - local($a[2]) = $a[2]; - print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n"; - print +($a[2] eq 'c') ? "" : "not ", "ok 25\n"; - undef @a; -} -print +($a[1] eq 'b') ? "" : "not ", "ok 26\n"; -print +($a[2] eq 'c') ? "" : "not ", "ok 27\n"; -print +(!defined $a[0]) ? "" : "not ", "ok 28\n"; - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n"; - -%h = ('a' => 1, 'b' => 2, 'c' => 3); -{ - local($h{'a'}) = 'foo'; - local($h{'b'}) = $h{'b'}; - print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n"; - print +($h{'b'} == 2) ? "" : "not ", "ok 31\n"; - local($h{'c'}); - delete $h{'c'}; -} -print +($h{'a'} == 1) ? "" : "not ", "ok 32\n"; -print +($h{'b'} == 2) ? "" : "not ", "ok 33\n"; -print +($h{'c'} == 3) ? "" : "not ", "ok 34\n"; - -# check for scope leakage -$a = 'outer'; -if (1) { local $a = 'inner' } -print +($a eq 'outer') ? "" : "not ", "ok 35\n"; - -# see if localization works when scope unwinds -local $m = 5; -eval { - for $m (6) { - local $m = 7; - die "bye"; - } -}; -print $m == 5 ? "" : "not ", "ok 36\n"; - -# see if localization works on tied arrays -{ - package TA; - sub TIEARRAY { bless [], $_[0] } - sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } - sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } - sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } - sub FETCHSIZE { scalar(@{$_[0]}) } - sub SHIFT { shift (@{$_[0]}) } - sub EXTEND {} -} - -tie @a, 'TA'; -@a = ('a', 'b', 'c'); -{ - local($a[1]) = 'foo'; - local($a[2]) = $a[2]; - print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n"; - print +($a[2] eq 'c') ? "" : "not ", "ok 38\n"; - @a = (); -} -print +($a[1] eq 'b') ? "" : "not ", "ok 39\n"; -print +($a[2] eq 'c') ? "" : "not ", "ok 40\n"; -print +(!defined $a[0]) ? "" : "not ", "ok 41\n"; - -{ - package TH; - sub TIEHASH { bless {}, $_[0] } - sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } - sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } - sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } - sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } -} - -# see if localization works on tied hashes -tie %h, 'TH'; -%h = ('a' => 1, 'b' => 2, 'c' => 3); - -{ - local($h{'a'}) = 'foo'; - local($h{'b'}) = $h{'b'}; - print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n"; - print +($h{'b'} == 2) ? "" : "not ", "ok 43\n"; - local($h{'c'}); - delete $h{'c'}; -} -print +($h{'a'} == 1) ? "" : "not ", "ok 44\n"; -print +($h{'b'} == 2) ? "" : "not ", "ok 45\n"; -print +($h{'c'} == 3) ? "" : "not ", "ok 46\n"; - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n"; - -# now try the same for %SIG - -$SIG{TERM} = 'foo'; -$SIG{INT} = \&foo; -$SIG{__WARN__} = $SIG{INT}; -{ - local($SIG{TERM}) = $SIG{TERM}; - local($SIG{INT}) = $SIG{INT}; - local($SIG{__WARN__}) = $SIG{__WARN__}; - print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 48\n"; - print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 49\n"; - print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 50\n"; - local($SIG{INT}); - delete $SIG{__WARN__}; -} -print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 51\n"; -print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 52\n"; -print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 53\n"; - -# and for %ENV - -$ENV{_X_} = 'a'; -$ENV{_Y_} = 'b'; -$ENV{_Z_} = 'c'; -{ - local($ENV{_X_}) = 'foo'; - local($ENV{_Y_}) = $ENV{_Y_}; - print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n"; - print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n"; - local($ENV{_Z_}); - delete $ENV{_Z_}; -} -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/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t deleted file mode 100755 index d57271a..0000000 --- a/contrib/perl5/t/op/lop.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl - -# -# test the logical operators '&&', '||', '!', 'and', 'or', 'not' -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..7\n"; - -my $test = 0; -for my $i (undef, 0 .. 2, "", "0 but true") { - my $true = 1; - my $false = 0; - for my $j (undef, 0 .. 2, "", "0 but true") { - $true &&= !( - ((!$i || !$j) != !($i && $j)) - or (!($i || $j) != (!$i && !$j)) - or (!!($i || $j) != !(!$i && !$j)) - or (!(!$i || !$j) != !!($i && $j)) - ); - $false ||= ( - ((!$i || !$j) == !!($i && $j)) - and (!!($i || $j) == (!$i && !$j)) - and ((!$i || $j) == ($i && !$j)) - and (($i || !$j) != (!$i && $j)) - ); - } - if (not $true) { - print "not "; - } elsif ($false) { - print "not "; - } - print "ok ", ++$test, "\n"; -} - -# $test == 6 -my $i = 0; -(($i ||= 1) &&= 3) += 4; -print "not " unless $i == 7; -print "ok ", ++$test, "\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t deleted file mode 100755 index c2a8211..0000000 --- a/contrib/perl5/t/op/magic.t +++ /dev/null @@ -1,228 +0,0 @@ -#!./perl - -BEGIN { - $| = 1; - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; -} - -use warnings; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_VMS = $^O eq 'VMS'; -$Is_Dos = $^O eq 'dos'; -$Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O eq 'cygwin'; -$PERL = ($Is_MSWin32 ? '.\perl' : './perl'); - -print "1..35\n"; - -eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval -if ($Is_MSWin32) { ok 1, `cmd /x /c set FOO` eq "FOO=hi there\n"; } -else { ok 1, `echo \$FOO` eq "hi there\n"; } - -unlink 'ajslkdfpqjsjfk'; -$! = 0; -open(FOO,'ajslkdfpqjsjfk'); -ok 2, $!, $!; -close FOO; # just mention it, squelch used-only-once - -if ($Is_MSWin32 || $Is_Dos) { - ok "3 # skipped",1; - ok "4 # skipped",1; -} -else { - # the next tests are embedded inside system simply because sh spits out - # a newline onto stderr when a child process kills itself with SIGINT. - system './perl', '-e', <<'END'; - - $| = 1; # command buffering - - $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1; - $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n"; - $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok\n"; - - sub ok3 { - if (($x = pop(@_)) eq "INT") { - print "ok 3\n"; - } - else { - print "not ok 3 ($x @_)\n"; - } - } - -END -} - -# can we slice ENV? -@val1 = @ENV{keys(%ENV)}; -@val2 = values(%ENV); -ok 5, join(':',@val1) eq join(':',@val2); -ok 6, @val1 > 1; - -# regex vars -'foobarbaz' =~ /b(a)r/; -ok 7, $` eq 'foo', $`; -ok 8, $& eq 'bar', $&; -ok 9, $' eq 'baz', $'; -ok 10, $+ eq 'a', $+; - -# $" -@a = qw(foo bar baz); -ok 11, "@a" eq "foo bar baz", "@a"; -{ - local $" = ','; - ok 12, "@a" eq "foo,bar,baz", "@a"; -} - -# $; -%h = (); -$h{'foo', 'bar'} = 1; -ok 13, (keys %h)[0] eq "foo\034bar", (keys %h)[0]; -{ - local $; = 'x'; - %h = (); - $h{'foo', 'bar'} = 1; - ok 14, (keys %h)[0] eq 'fooxbar', (keys %h)[0]; -} - -# $?, $@, $$ -system qq[$PERL -e "exit(0)"]; -ok 15, $? == 0, $?; -system qq[$PERL -e "exit(1)"]; -ok 16, $? != 0, $?; - -eval { die "foo\n" }; -ok 17, $@ eq "foo\n", $@; - -ok 18, $$ > 0, $$; - -# $^X and $0 -{ - if ($^O eq 'qnx') { - chomp($wd = `/usr/bin/fullpath -t`); - } - elsif($Is_Cygwin) { - # Cygwin turns the symlink into the real file - chomp($wd = `pwd`); - $wd =~ s#/t$##; - } - elsif($Is_os2) { - $wd = Cwd::sys_cwd(); - } - else { - $wd = '.'; - } - my $perl = "$wd/perl"; - my $headmaybe = ''; - my $tailmaybe = ''; - $script = "$wd/show-shebang"; - if ($Is_MSWin32) { - chomp($wd = `cd`); - $wd =~ s|\\|/|g; - $perl = "$wd/perl.exe"; - $script = "$wd/show-shebang.bat"; - $headmaybe = <<EOH ; -\@rem =' -\@echo off -$perl -x \%0 -goto endofperl -\@rem '; -EOH - $tailmaybe = <<EOT ; - -__END__ -:endofperl -EOT - } - elsif ($Is_os2) { - $script = "./show-shebang"; - } - if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang - $headmaybe = <<EOH ; - eval 'exec ./perl -S \$0 \${1+"\$\@"}' - if 0; -EOH - } - $s1 = "\$^X is $perl, \$0 is $script\n"; - ok 19, open(SCRIPT, ">$script"), $!; - ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; -#!$wd/perl -EOB -print "\$^X is $^X, \$0 is $0\n"; -EOF - ok 21, close(SCRIPT), $!; - ok 22, chmod(0755, $script), $!; - $_ = `$script`; - s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; - s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl - s{is perl}{is $perl}; # for systems where $^X is only a basename - s{\\}{/}g; - ok 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:"; - $_ = `$perl $script`; - s/\.exe//i if $Is_Dos or $Is_os2; - s{\\}{/}g; - ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`"; - ok 25, unlink($script), $!; -} - -# $], $^O, $^T -ok 26, $] >= 5.00319, $]; -ok 27, $^O; -ok 28, $^T > 850000000, $^T; - -if ($Is_VMS || $Is_Dos) { - ok "29 # skipped", 1; - ok "30 # skipped", 1; -} -else { - $PATH = $ENV{PATH}; - $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; - $ENV{foo} = "bar"; - %ENV = (); - $ENV{PATH} = $PATH; - $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; - ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "") - : (`echo \$foo` eq "\n") ); - - $ENV{__NoNeSuCh} = "foo"; - $0 = "bar"; - ok 30, ($Is_MSWin32 ? (`cmd /x /c set __NoNeSuCh` eq "__NoNeSuCh=foo\n") - : (`echo \$__NoNeSuCh` eq "foo\n") ); -} - -{ - local $SIG{'__WARN__'} = sub { print "# @_\nnot " }; - $! = undef; - print "ok 31\n"; -} - -# test case-insignificance of %ENV (these tests must be enabled only -# when perl is compiled with -DENV_IS_CASELESS) -if ($Is_MSWin32) { - %ENV = (); - $ENV{'Foo'} = 'bar'; - $ENV{'fOo'} = 'baz'; - ok 32, (scalar(keys(%ENV)) == 1); - ok 33, exists($ENV{'FOo'}); - ok 34, (delete($ENV{'foO'}) eq 'baz'); - ok 35, (scalar(keys(%ENV)) == 0); -} -else { - ok "32 # skipped: no caseless %ENV support",1; - ok "33 # skipped: no caseless %ENV support",1; - ok "34 # skipped: no caseless %ENV support",1; - ok "35 # skipped: no caseless %ENV support",1; -} diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t deleted file mode 100755 index be4df75..0000000 --- a/contrib/perl5/t/op/method.t +++ /dev/null @@ -1,187 +0,0 @@ -#!./perl - -# -# test method calls and autoloading. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..53\n"; - -@A::ISA = 'B'; -@B::ISA = 'C'; - -sub C::d {"C::d"} -sub D::d {"D::d"} - -my $cnt = 0; -sub test { - print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; - # print "not " unless shift eq shift; - 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. -test (A->d, "D::d"); # Update hash table; - -{ - local @A::ISA = qw(C); # Update hash table with split() assignment - test (A->d, "C::d"); - $#A::ISA = -1; - test (eval { A->d } || "fail", "fail"); -} -test (A->d, "D::d"); - -{ - local *B::d; - eval 'sub B::d {"B::d1"}'; # Import now. - test (A->d, "B::d1"); # Update hash table; - undef &B::d; - test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); -} - -test (A->d, "D::d"); # Back to previous state - -eval 'sub B::d {"B::d2"}'; # Import now. -test (A->d, "B::d2"); # Update hash table; - -# What follows is hardly guarantied to work, since the names in scripts -# are already linked to "pruned" globs. Say, `undef &B::d' if it were -# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. - -undef &B::d; -delete $B::{d}; -test (A->d, "C::d"); # Update hash table; - -eval 'sub B::d {"B::d3"}'; # Import now. -test (A->d, "B::d3"); # Update hash table; - -delete $B::{d}; -*dummy::dummy = sub {}; # Mark as updated -test (A->d, "C::d"); - -eval 'sub B::d {"B::d4"}'; # Import now. -test (A->d, "B::d4"); # Update hash table; - -delete $B::{d}; # Should work without any help too -test (A->d, "C::d"); - -{ - local *C::d; - test (eval { A->d } || "nope", "nope"); -} -test (A->d, "C::d"); - -*A::x = *A::d; # See if cache incorrectly follows synonyms -A->d; -test (eval { A->x } || "nope", "nope"); - -eval <<'EOF'; -sub C::e; -BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg -sub Y::f; -$counter = 0; - -@X::ISA = 'Y'; -@Y::ISA = 'B'; - -sub B::AUTOLOAD { - my $c = ++$counter; - my $method = $B::AUTOLOAD; - my $msg = "B: In $method, $c"; - eval "sub $method { \$msg }"; - goto &$method; -} -sub C::AUTOLOAD { - my $c = ++$counter; - my $method = $C::AUTOLOAD; - my $msg = "C: In $method, $c"; - eval "sub $method { \$msg }"; - goto &$method; -} -EOF - -test(A->e(), "C: In C::e, 1"); # We get a correct autoload -test(A->e(), "C: In C::e, 1"); # Which sticks - -test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top -test(A->ee(), "B: In A::ee, 2"); # Which sticks - -test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method -test(Y->f(), "B: In Y::f, 3"); # Which sticks - -# This test is not intended to be reasonable. It is here just to let you -# know that you broke some old construction. Feel free to rewrite the test -# if your patch breaks it. - -*B::AUTOLOAD = sub { - my $c = ++$counter; - my $method = $AUTOLOAD; - *$AUTOLOAD = sub { "new B: In $method, $c" }; - goto &$AUTOLOAD; -}; - -test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload -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"); -} - -{ - test(do { use Config; eval 'Config->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); - test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); -} - -test(do { eval 'E->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); -test(do { eval '$e = bless {}, "E"; $e->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); - diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t deleted file mode 100755 index 35437a4..0000000 --- a/contrib/perl5/t/op/misc.t +++ /dev/null @@ -1,603 +0,0 @@ -#!./perl - -# NOTE: Please don't add tests to this file unless they *need* to be run in -# separate executable and can't simply use eval. - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { while($tmpfile && unlink $tmpfile){} } - -$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); - -for (@prgs){ - my $switch; - if (s/^\s*(-\w.*)//){ - $switch = $1; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; - $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; - $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking - - print TEST $prog, "\n"; - close TEST or die "Cannot close $tmpfile: $!"; - - if ($^O eq 'MSWin32') { - $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; - } - else { - $results = `./perl $switch $tmpfile 2>&1`; - } - $status = $?; - $results =~ s/\n+$//; - $results =~ s/at\s+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 ) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ -()=() -######## -$a = ":="; split /($a)/o, "a:=b:=c"; print "@_" -EXPECT -a := b := c -######## -$cusp = ~0 ^ (~0 >> 1); -use integer; -$, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; -EXPECT -7 0 0 8 ! -######## -$foo=undef; $foo->go; -EXPECT -Can't call method "go" on an undefined value at - line 1. -######## -BEGIN - { - "foo"; - } -######## -$array[128]=1 -######## -$x=0x0eabcd; print $x->ref; -EXPECT -Can't call method "ref" without a package or object reference at - line 1. -######## -chop ($str .= <DATA>); -######## -close ($banana); -######## -$x=2;$y=3;$x<$y ? $x : $y += 23;print $x; -EXPECT -25 -######## -eval {sub bar {print "In bar";}} -######## -system './perl -ne "print if eof" /dev/null' -######## -chop($file = <DATA>); -######## -package N; -sub new {my ($obj,$n)=@_; bless \$n} -$aa=new N 1; -$aa=12345; -print $aa; -EXPECT -12345 -######## -%@x=0; -EXPECT -Can't modify hash dereference in repeat (x) at - line 1, near "0;" -Execution of - aborted due to compilation errors. -######## -$_="foo"; -printf(STDOUT "%s\n", $_); -EXPECT -foo -######## -push(@a, 1, 2, 3,) -######## -quotemeta "" -######## -for ("ABCDE") { - ⊂ -s/./&sub($&)/eg; -print;} -sub sub {local($_) = @_; -$_ x 4;} -EXPECT -Modification of a read-only value attempted at - line 3. -######## -package FOO;sub new {bless {FOO => BAR}}; -package main; -use strict vars; -my $self = new FOO; -print $$self{FOO}; -EXPECT -BAR -######## -$_="foo"; -s/.{1}//s; -print; -EXPECT -oo -######## -print scalar ("foo","bar") -EXPECT -bar -######## -sub by_number { $a <=> $b; };# inline function for sort below -$as_ary{0}="a0"; -@ordered_array=sort by_number keys(%as_ary); -######## -sub NewShell -{ - local($Host) = @_; - my($m2) = $#Shells++; - $Shells[$m2]{HOST} = $Host; - return $m2; -} - -sub ShowShell -{ - local($i) = @_; -} - -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -######## - { - package FAKEARRAY; - - sub TIEARRAY - { print "TIEARRAY @_\n"; - die "bomb out\n" unless $count ++ ; - bless ['foo'] - } - sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } - sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } - sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } - } - -eval 'tie @h, FAKEARRAY, fred' ; -tie @h, FAKEARRAY, fred ; -EXPECT -TIEARRAY FAKEARRAY fred -TIEARRAY FAKEARRAY fred -DESTROY -######## -BEGIN { die "phooey\n" } -EXPECT -phooey -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { 1/$zero } -EXPECT -Illegal division by zero at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { undef = 0 } -EXPECT -Modification of a read-only value attempted at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -{ - package foo; - sub PRINT { - shift; - print join(' ', reverse @_)."\n"; - } - sub PRINTF { - shift; - my $fmt = shift; - print sprintf($fmt, @_)."\n"; - } - sub TIEHANDLE { - bless {}, shift; - } - sub READLINE { - "Out of inspiration"; - } - sub DESTROY { - print "and destroyed as well\n"; - } - sub READ { - shift; - print STDOUT "foo->can(READ)(@_)\n"; - return 100; - } - sub GETC { - shift; - print STDOUT "Don't GETC, Get Perl\n"; - return "a"; - } -} -{ - local(*FOO); - tie(*FOO,'foo'); - print FOO "sentence.", "reversed", "a", "is", "This"; - print "-- ", <FOO>, " --\n"; - my($buf,$len,$offset); - $buf = "string"; - $len = 10; $offset = 1; - read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; - getc(FOO) eq "a" or die "foo->GETC failed"; - printf "%s is number %d\n", "Perl", 1; -} -EXPECT -This is a reversed sentence. --- Out of inspiration -- -foo->can(READ)(string 10 1) -Don't GETC, Get Perl -Perl is number 1 -and destroyed as well -######## -my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" -EXPECT -2 2 2 -######## -@a = ($a, $b, $c, $d) = (5, 6); -print "ok\n" - if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); -EXPECT -ok -######## -print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); -EXPECT -ok -######## -print "ok\n" if ("\0" lt "\xFF"); -EXPECT -ok -######## -open(H,'op/misc.t'); # must be in the 't' directory -stat(H); -print "ok\n" if (-e _ and -f _ and -r _); -EXPECT -ok -######## -sub thing { 0 || return qw(now is the time) } -print thing(), "\n"; -EXPECT -nowisthetime -######## -$ren = 'joy'; -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print $ren, ' ' } -print $ren, "\n"; -EXPECT -happy joy -######## -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' } -print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; -EXPECT -happy joy -######## -package p; -sub func { print 'really ' unless wantarray; 'p' } -sub groovy { 'groovy' } -package main; -print p::func()->groovy(), "\n" -EXPECT -really groovy -######## -@list = ([ 'one', 1 ], [ 'two', 2 ]); -sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } -print scalar(map &func($_), 1 .. 3), " ", - scalar(map scalar &func($_), 1 .. 3), "\n"; -EXPECT -2 3 -######## -($k, $s) = qw(x 0); -@{$h{$k}} = qw(1 2 4); -for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } -print "bogus\n" unless $s == 7; -######## -my $a = 'outer'; -eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; -eval { my $x = 'peace'; eval q[ print "$x\n" ] } -EXPECT -inner peace -######## --w -$| = 1; -sub foo { - print "In foo1\n"; - eval 'sub foo { print "In foo2\n" }'; - print "Exiting foo1\n"; -} -foo; -foo; -EXPECT -In foo1 -Subroutine foo redefined at (eval 1) line 1. -Exiting foo1 -In foo2 -######## -$s = 0; -map {#this newline here tickles the bug -$s += $_} (1,2,4); -print "eat flaming death\n" unless ($s == 7); -######## -sub foo { local $_ = shift; split; @_ } -@x = foo(' x y z '); -print "you die joe!\n" unless "@x" eq 'x y z'; -######## -/(?{"{"})/ # Check it outside of eval too -EXPECT -Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern -Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. -######## -/(?{"{"}})/ # Check it outside of eval too -EXPECT -Unmatched right curly bracket at (re_eval 1) line 1, at end of line -syntax error at (re_eval 1) line 1, near ""{"}" -Compilation failed in regexp at - line 1. -######## -BEGIN { @ARGV = qw(a b c d e) } -BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } -END { print "end <",shift,">\nargv <@ARGV>\n" } -INIT { print "init <",shift,">\n" } -CHECK { print "check <",shift,">\n" } -EXPECT -argv <a b c d e> -begin <a> -check <b> -init <c> -end <d> -argv <e> -######## --l -# fdopen from a system descriptor to a system descriptor used to close -# the former. -open STDERR, '>&=STDOUT' or die $!; -select STDOUT; $| = 1; print fileno STDOUT or die $!; -select STDERR; $| = 1; print fileno STDERR or die $!; -EXPECT -1 -2 -######## --w -sub testme { my $a = "test"; { local $a = "new test"; print $a }} -EXPECT -Can't localize lexical variable $a at - line 2. -######## -package X; -sub ascalar { my $r; bless \$r } -sub DESTROY { print "destroyed\n" }; -package main; -*s = ascalar X; -EXPECT -destroyed -######## -package X; -sub anarray { bless [] } -sub DESTROY { print "destroyed\n" }; -package main; -*a = anarray X; -EXPECT -destroyed -######## -package X; -sub ahash { bless {} } -sub DESTROY { print "destroyed\n" }; -package main; -*h = ahash X; -EXPECT -destroyed -######## -package X; -sub aclosure { my $x; bless sub { ++$x } } -sub DESTROY { print "destroyed\n" }; -package main; -*c = aclosure X; -EXPECT -destroyed -######## -package X; -sub any { bless {} } -my $f = "FH000"; # just to thwart any future optimisations -sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } -sub DESTROY { print "destroyed\n" } -package main; -$x = any X; # to bump sv_objcount. IO objs aren't counted?? -*f = afh X; -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/(??{ $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 in numeric eq (==) at - line 4. -######## -$x = sub {}; -foo(); -sub foo { eval { return }; } -print "ok\n"; -EXPECT -ok -######## -my @l = qw(hello.* world); -my $x; - -foreach $x (@l) { - print "before - $x\n"; - $x = "\Q$x\E"; - print "quotemeta - $x\n"; - $x = "\u$x"; - print "ucfirst - $x\n"; - $x = "\l$x"; - print "lcfirst - $x\n"; - $x = "\U$x\E"; - print "uc - $x\n"; - $x = "\L$x\E"; - print "lc - $x\n"; -} -EXPECT -before - hello.* -quotemeta - hello\.\* -ucfirst - Hello\.\* -lcfirst - hello\.\* -uc - HELLO\.\* -lc - hello\.\* -before - world -quotemeta - world -ucfirst - World -lcfirst - world -uc - WORLD -lc - world -######## -sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } -my $x = "foo"; -{ f } continue { print $x, "\n" } -EXPECT -foo -######## -sub C () { 1 } -sub M { $_[0] = 2; } -eval "C"; -M(C); -EXPECT -Modification of a read-only value attempted at - line 2. -######## -print qw(ab a\b a\\b); -EXPECT -aba\ba\b -######## -# This test is here instead of pragma/locale.t because -# the bug depends on in the internal state of the locale -# settings and pragma/locale messes up that state pretty badly. -# We need a "fresh run". -BEGIN { - eval { require POSIX }; - if ($@) { - exit(0); # running minitest? - } -} -use Config; -my $have_setlocale = $Config{d_setlocale} eq 'define'; -$have_setlocale = 0 if $@; -# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" -# and mingw32 uses said silly CRT -$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -exit(0) unless $have_setlocale; -my @locales; -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { - while(<LOCALES>) { - chomp; - push(@locales, $_); - } - close(LOCALES); -} -exit(0) unless @locales; -for (@locales) { - use POSIX qw(locale_h); - use locale; - setlocale(LC_NUMERIC, $_) or next; - my $s = sprintf "%g %g", 3.1, 3.1; - next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; - print "$_ $s\n"; -} -EXPECT diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t deleted file mode 100755 index c5a090c..0000000 --- a/contrib/perl5/t/op/mkdir.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -print "1..9\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Path; -rmtree('blurfl'); - -# tests 3 and 7 rather naughtily expect English error messages -$ENV{'LC_ALL'} = 'C'; -$ENV{LANGUAGE} = 'C'; # GNU locale extension - -print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); -print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -print ($! =~ /cannot move|exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); -print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); -print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); -print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -print ($! =~ /cannot find|such|exist|not found/i ? "ok 7\n" : "# $!\nnot ok 7\n"); -print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n"); -print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n"); diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t deleted file mode 100755 index 601e1d6..0000000 --- a/contrib/perl5/t/op/my.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -# $RCSfile: my.t,v $ - -print "1..31\n"; - -sub foo { - my($a, $b) = @_; - my $c; - my $d; - $c = "ok 3\n"; - $d = "ok 4\n"; - { my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n"); - ($x, $y) = ($a, $c); } - print $a, $b; - $c . $d; -} - -$a = "ok 5\n"; -$b = "ok 6\n"; -$c = "ok 7\n"; -$d = "ok 8\n"; - -print &foo("ok 1\n","ok 2\n"); - -print $a,$b,$c,$d,$x,$y; - -# same thing, only with arrays and associative arrays - -sub foo2 { - my($a, @b) = @_; - my(@c, %d); - @c = "ok 13\n"; - $d{''} = "ok 14\n"; - { my($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); } - print $a, @b; - $c[0] . $d{''}; -} - -$a = "ok 15\n"; -@b = "ok 16\n"; -@c = "ok 17\n"; -$d{''} = "ok 18\n"; - -print &foo2("ok 11\n","ok 12\n"); - -print $a,@b,@c,%d,$x,$y; - -my $i = "outer"; - -if (my $i = "inner") { - print "not " if $i ne "inner"; -} -print "ok 21\n"; - -if ((my $i = 1) == 0) { - print "not "; -} -else { - print "not" if $i != 1; -} -print "ok 22\n"; - -my $j = 5; -while (my $i = --$j) { - print("not "), last unless $i > 0; -} -continue { - print("not "), last unless $i > 0; -} -print "ok 23\n"; - -$j = 5; -for (my $i = 0; (my $k = $i) < $j; ++$i) { - print("not "), last unless $i >= 0 && $i < $j && $i == $k; -} -print "ok 24\n"; -print "not " if defined $k; -print "ok 25\n"; - -foreach my $i (26, 27) { - print "ok $i\n"; -} - -print "not " if $i ne "outer"; -print "ok 28\n"; - -# Ensure that C<my @y> (without parens) doesn't force scalar context. -my @x; -{ @x = my @y } -print +(@x ? "not " : ""), "ok 29\n"; -{ @x = my %y } -print +(@x ? "not " : ""), "ok 30\n"; - -# Found in HTML::FormatPS -my %fonts = qw(nok 31); -for my $full (keys %fonts) { - $full =~ s/^n//; - # Supposed to be copy-on-write via force_normal after a THINKFIRST check. - print "$full $fonts{nok}\n"; -} diff --git a/contrib/perl5/t/op/my_stash.t b/contrib/perl5/t/op/my_stash.t deleted file mode 100755 index 4a1d502..0000000 --- a/contrib/perl5/t/op/my_stash.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl - -package Foo; - -BEGIN { - @INC = '../lib'; -} - -use Test; - -plan tests => 7; - -use constant MyClass => 'Foo::Bar::Biz::Baz'; - -{ - package Foo::Bar::Biz::Baz; -} - -for (qw(Foo Foo:: MyClass __PACKAGE__)) { - eval "sub { my $_ \$obj = shift; }"; - ok ! $@; -# print $@ if $@; -} - -use constant NoClass => 'Nope::Foo::Bar::Biz::Baz'; - -for (qw(Nope Nope:: NoClass)) { - eval "sub { my $_ \$obj = shift; }"; - ok $@; -# print $@ if $@; -} diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t deleted file mode 100755 index 411a0b4..0000000 --- a/contrib/perl5/t/op/nothr5005.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -# NOTE: Please don't add tests to this file unless they *need* to be run in -# separate executable and can't simply use eval. - -BEGIN - { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; - import Config; - if ($Config{'use5005threads'}) - { - print "1..0 # Skip: this perl is threaded\n"; - exit 0; - } - } - - -$|=1; - -print "1..9\n"; -$t = 1; -sub foo { local(@_) = ('p', 'q', 'r'); } -sub bar { unshift @_, 'D'; @_ } -sub baz { push @_, 'E'; return @_ } -for (1..3) - { - print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr'; - print "ok ",$t++,"\n"; - print "not" unless join('',bar('d')) eq 'Dd'; - print "ok ",$t++,"\n"; - print "not" unless join('',baz('e')) eq 'eE'; - print "ok ",$t++,"\n"; - } diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t deleted file mode 100755 index f3c9867..0000000 --- a/contrib/perl5/t/op/numconvert.t +++ /dev/null @@ -1,192 +0,0 @@ -#!./perl - -# -# test the conversion operators -# -# Notations: -# -# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N -# Compare with application of op-N, then reporter-N -# Right below are descriptions of different ops and reporters. - -# We do not use these subroutines any more, sub overhead makes a "switch" -# solution better: - -# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) - -# *0 = sub {--$_[0]}; # - -# *1 = sub {++$_[0]}; # + - -# # Converters -# *2 = sub { $_[0] = $max_uv & $_[0]}; # U -# *3 = sub { use integer; $_[0] += $zero}; # I -# *4 = sub { $_[0] += $zero}; # N -# *5 = sub { $_[0] = "$_[0]" }; # P - -# # Side effects -# *6 = sub { $max_uv & $_[0]}; # u -# *7 = sub { use integer; $_[0] + $zero}; # i -# *8 = sub { $_[0] + $zero}; # n -# *9 = sub { $_[0] . "" }; # p - -# # Reporters -# sub a2 { sprintf "%u", $_[0] } # U -# sub a3 { sprintf "%d", $_[0] } # I -# sub a4 { sprintf "%g", $_[0] } # N -# sub a5 { "$_[0]" } # P - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict 'vars'; - -my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; - -# Bulk out if unsigned type is hopelessly wrong: -my $max_uv1 = ~0; -my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here -my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here - -print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; -if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { - print "1..0 # skipped: unsigned perl arithmetic is not sane"; - eval { require Config; import Config }; - use vars qw(%Config); - if ($Config{d_quad} eq 'define') { - print " (common in 64-bit platforms)"; - } - print "\n"; - exit 0; -} - -my $st_t = 4*4; # We try 4 initializers and 4 reporters - -my $num = 0; -$num += 10**$_ - 4**$_ for 1.. $max_chain; -$num *= $st_t; -print "1..$num\n"; # In fact 15 times more subsubtests... - -my $max_uv = ~0; -my $max_iv = int($max_uv/2); -my $zero = 0; - -my $l_uv = length $max_uv; -my $l_iv = length $max_iv; - -# Hope: the first digits are good -my $larger_than_uv = substr 97 x 100, 0, $l_uv; -my $smaller_than_iv = substr 12 x 100, 0, $l_iv; -my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); - -my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, - $max_uv, $max_uv + 1); -unshift @list, (reverse map -$_, @list), 0; # 15 elts -@list = map "$_", @list; # Normalize - -# print "@list\n"; - - -my @opnames = split //, "-+UINPuinp"; - -# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input - -#print "@list\n"; -#print "'@ops'\n"; - -my $test = 1; -my $nok; -for my $num_chain (1..$max_chain) { - my @ops = map [split //], grep /[4-9]/, - map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; - - #@ops = ([]) unless $num_chain; - #@ops = ([6, 4]); - - # print "'@ops'\n"; - for my $op (@ops) { - for my $first (2..5) { - for my $last (2..5) { - $nok = 0; - my @otherops = grep $_ <= 3, @$op; - my @curops = ($op,\@otherops); - - for my $num (@list) { - my $inpt; - my @ans; - - for my $short (0, 1) { - # undef $inpt; # Forget all we had - some bugs were masked - - $inpt = $num; # Try to not contaminate $num... - $inpt = "$inpt"; - if ($first == 2) { - $inpt = $max_uv & $inpt; # U 2 - } elsif ($first == 3) { - use integer; $inpt += $zero; # I 3 - } elsif ($first == 4) { - $inpt += $zero; # N 4 - } else { - $inpt = "$inpt"; # P 5 - } - - # Saves 20% of time - not with this logic: - #my $tmp = $inpt; - #my $tmp1 = $num; - #next if $num_chain > 1 - # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... - - for my $curop (@{$curops[$short]}) { - if ($curop < 5) { - if ($curop < 3) { - if ($curop == 0) { - --$inpt; # - 0 - } elsif ($curop == 1) { - ++$inpt; # + 1 - } else { - $inpt = $max_uv & $inpt; # U 2 - } - } elsif ($curop == 3) { - use integer; $inpt += $zero; - } else { - $inpt += $zero; # N 4 - } - } elsif ($curop < 8) { - if ($curop == 5) { - $inpt = "$inpt"; # P 5 - } elsif ($curop == 6) { - $max_uv & $inpt; # u 6 - } else { - use integer; $inpt + $zero; - } - } elsif ($curop == 8) { - $inpt + $zero; # n 8 - } else { - $inpt . ""; # p 9 - } - } - - if ($last == 2) { - $inpt = sprintf "%u", $inpt; # U 2 - } elsif ($last == 3) { - $inpt = sprintf "%d", $inpt; # I 3 - } elsif ($last == 4) { - $inpt = sprintf "%g", $inpt; # N 4 - } else { - $inpt = "$inpt"; # P 5 - } - push @ans, $inpt; - } - $nok++, - print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" - if $ans[0] ne $ans[1]; - } - print "not " if $nok; - print "ok $test\n"; - #print $txt if $nok; - $test++; - } - } - } -} diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t deleted file mode 100755 index fe155d3..0000000 --- a/contrib/perl5/t/op/oct.t +++ /dev/null @@ -1,88 +0,0 @@ -#!./perl - -print "1..50\n"; - -print +(oct('0b1_0101') == 0b101_01) ? "ok" : "not ok", " 1\n"; -print +(oct('0b10_101') == 0_2_5) ? "ok" : "not ok", " 2\n"; -print +(oct('0b101_01') == 2_1) ? "ok" : "not ok", " 3\n"; -print +(oct('0b1010_1') == 0x1_5) ? "ok" : "not ok", " 4\n"; - -print +(oct('b1_0101') == 0b10101) ? "ok" : "not ok", " 5\n"; -print +(oct('b10_101') == 025) ? "ok" : "not ok", " 6\n"; -print +(oct('b101_01') == 21) ? "ok" : "not ok", " 7\n"; -print +(oct('b1010_1') == 0x15) ? "ok" : "not ok", " 8\n"; - -print +(oct('01_234') == 0b10_1001_1100) ? "ok" : "not ok", " 9\n"; -print +(oct('012_34') == 01234) ? "ok" : "not ok", " 10\n"; -print +(oct('0123_4') == 668) ? "ok" : "not ok", " 11\n"; -print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; - -print +(oct('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n"; -print +(oct('0x12_34') == 01_1064) ? "ok" : "not ok", " 14\n"; -print +(oct('0x123_4') == 4660) ? "ok" : "not ok", " 15\n"; -print +(oct('0x1234') == 0x12_34) ? "ok" : "not ok", " 16\n"; - -print +(oct('x1_234') == 0b100100011010_0) ? "ok" : "not ok", " 17\n"; -print +(oct('x12_34') == 0_11064) ? "ok" : "not ok", " 18\n"; -print +(oct('x123_4') == 4660) ? "ok" : "not ok", " 19\n"; -print +(oct('x1234') == 0x_1234) ? "ok" : "not ok", " 20\n"; - -print +(hex('01_234') == 0b_1001000110100) ? "ok" : "not ok", " 21\n"; -print +(hex('012_34') == 011064) ? "ok" : "not ok", " 22\n"; -print +(hex('0123_4') == 4660) ? "ok" : "not ok", " 23\n"; -print +(hex('01234_') == 0x1234) ? "ok" : "not ok", " 24\n"; - -print +(hex('0x_1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; -print +(hex('0x1_234') == 011064) ? "ok" : "not ok", " 26\n"; -print +(hex('0x12_34') == 4660) ? "ok" : "not ok", " 27\n"; -print +(hex('0x1234_') == 0x1234) ? "ok" : "not ok", " 28\n"; - -print +(hex('x_1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; -print +(hex('x12_34') == 011064) ? "ok" : "not ok", " 30\n"; -print +(hex('x123_4') == 4660) ? "ok" : "not ok", " 31\n"; -print +(hex('x1234_') == 0x1234) ? "ok" : "not ok", " 32\n"; - -print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ? - "ok" : "not ok", " 33\n"; -print +(oct('037_777_777_777') == 4294967295) ? - "ok" : "not ok", " 34\n"; -print +(oct('0xffff_ffff') == 4294967295) ? - "ok" : "not ok", " 35\n"; - -print +(hex('0xff_ff_ff_ff') == 4294967295) ? - "ok" : "not ok", " 36\n"; - -$_ = "\0_7_7"; -print length eq 5 ? "ok" : "not ok", " 37\n"; -print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; -chop, chop, chop, chop; -print $_ eq "\0" ? "ok" : "not ok", " 39\n"; -if (ord("\t") != 9) { - # question mark is 111 in 1047, 037, && POSIX-BC - print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; -} -else { - print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; -} - -$_ = "\x_7_7"; -print length eq 5 ? "ok" : "not ok", " 41\n"; -print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; -chop, chop, chop, chop; -print $_ eq "\0" ? "ok" : "not ok", " 43\n"; -if (ord("\t") != 9) { - # / is 97 in 1047, 037, && POSIX-BC - print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; -} -else { - print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; -} - -print +(oct('0b'.( '0'x10).'1_0101') == 0b101_01) ? "ok" : "not ok", " 45\n"; -print +(oct('0b'.( '0'x100).'1_0101') == 0b101_01) ? "ok" : "not ok", " 46\n"; -print +(oct('0b'.('0'x1000).'1_0101') == 0b101_01) ? "ok" : "not ok", " 47\n"; - -print +(hex(( '0'x10).'01234') == 0x1234) ? "ok" : "not ok", " 48\n"; -print +(hex(( '0'x100).'01234') == 0x1234) ? "ok" : "not ok", " 49\n"; -print +(hex(('0'x1000).'01234') == 0x1234) ? "ok" : "not ok", " 50\n"; - diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t deleted file mode 100755 index 22ff3af..0000000 --- a/contrib/perl5/t/op/ord.t +++ /dev/null @@ -1,23 +0,0 @@ -#!./perl - -print "1..5\n"; - -# compile time evaluation - -# 65 ASCII -# 193 EBCDIC -if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} - -print "not " unless ord(chr(500)) == 500; -print "ok 2\n"; - -# run time evaluation - -$x = 'ABC'; -if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n";} - -if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";} - -$x = 500; -print "not " unless ord(chr($x)) == $x; -print "ok 5\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t deleted file mode 100755 index 67bd547..0000000 --- a/contrib/perl5/t/op/pack.t +++ /dev/null @@ -1,418 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..159\n"; - -$format = "c2 x5 C C x s d i l a6"; -# Need the expression in here to force ary[5] to be numeric. This avoids -# test2 failing because ary2 goes str->numeric->str and ary doesn't. -@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); -$foo = pack($format,@ary); -@ary2 = unpack($format,$foo); - -print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); - -$out1=join(':',@ary); -$out2=join(':',@ary2); -# Using long double NVs may introduce greater accuracy than wanted. -$out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; -$out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; -print ($out1 eq $out2? "ok 2\n" : "not ok 2\n"); - -print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); - -# How about counting bits? - -print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 - ? "ok 4\n" : "not ok 4 $x\n"; - -print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 - ? "ok 5\n" : "not ok 5 $x\n"; - -print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 - ? "ok 6\n" : "not ok 6 $x\n"; - -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") - || die "Can't open ../perl or ../perl.exe: $!\n"; -sysread BIN, $foo, 8192; -close BIN; - -$sum = unpack("%32b*", $foo); -$longway = unpack("b*", $foo); -print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n"; - -print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF - ? "ok 9\n" : "not ok 9 $x\n"; - -# check 'w' -my $test=10; -my @x = (5,130,256,560,32000,3097152,268435455,1073741844, - '4503599627365785','23728385234614992549757750638446'); -my $x = pack('w*', @x); -my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; - -print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++; - -@y = unpack('w*', $y); -my $a; -while ($a = pop @x) { - my $b = pop @y; - print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; -} - -@y = unpack('w2', $x); - -print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; -print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++; - -# test exeptions -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -# -# test the "p" template - -# literals -print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n"); - -# scalars -print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); - -# temps -sub foo { my $a = "a"; return $a . $a++ . $a++ } -{ - use warnings; - my $last = $test; - local $SIG{__WARN__} = sub { - print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ - }; - my $junk = pack("p", &foo); - print "not ok ", $test++, "\n" if $last == $test; -} - -# undef should give null pointer -print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); - -# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives -# 4294967295 instead of -1) -# see #ifdef __osf__ in pp.c pp_unpack -# Test 30: -print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); - -# 31..36: test the pack lengths of s S i I l L -print "not " unless length(pack("s", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("S", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("I", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("l", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("L", 0)) == 4; -print "ok ", $test++, "\n"; - -# 37..40: test the pack lengths of n N v V - -print "not " unless length(pack("n", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("N", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("v", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("V", 0)) == 4; -print "ok ", $test++, "\n"; - -# 41..56: test unpack-pack lengths - -my @templates = qw(c C i I s S l L n N v V f d); - -# quads not supported everywhere: if not, retest floats/doubles -# to preserve the test count... -eval { my $q = pack("q",0) }; -push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d); - -foreach my $t (@templates) { - my @t = unpack("$t*", pack("$t*", 12, 34)); - print "not " - 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..73: test the ascii template types (A, a, Z) - -print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -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 \0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z3', "foo") eq "fo\0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -# 74..79: 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"; - -# 80..139: pack <-> unpack bijectionism - -# 80.. 84 c -foreach my $c (-128, -1, 0, 1, 127) { - print "not " unless unpack("c", pack("c", $c)) == $c; - print "ok ", $test++, "\n"; -} - -# 85.. 89: C -foreach my $C (0, 1, 127, 128, 255) { - print "not " unless unpack("C", pack("C", $C)) == $C; - print "ok ", $test++, "\n"; -} - -# 90.. 94: s -foreach my $s (-32768, -1, 0, 1, 32767) { - print "not " unless unpack("s", pack("s", $s)) == $s; - print "ok ", $test++, "\n"; -} - -# 95.. 99: S -foreach my $S (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("S", pack("S", $S)) == $S; - print "ok ", $test++, "\n"; -} - -# 100..104: i -foreach my $i (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("i", pack("i", $i)) == $i; - print "ok ", $test++, "\n"; -} - -# 105..109: I -foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("I", pack("I", $I)) == $I; - print "ok ", $test++, "\n"; -} - -# 110..114: l -foreach my $l (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("l", pack("l", $l)) == $l; - print "ok ", $test++, "\n"; -} - -# 115..119: L -foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("L", pack("L", $L)) == $L; - print "ok ", $test++, "\n"; -} - -# 120..124: n -foreach my $n (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("n", pack("n", $n)) == $n; - print "ok ", $test++, "\n"; -} - -# 125..129: v -foreach my $v (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("v", pack("v", $v)) == $v; - print "ok ", $test++, "\n"; -} - -# 130..134: N -foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("N", pack("N", $N)) == $N; - print "ok ", $test++, "\n"; -} - -# 135..139: V -foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("V", pack("V", $V)) == $V; - print "ok ", $test++, "\n"; -} - -# 140..143: 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"; - -# 144..152: / - -my $z; -eval { ($x) = unpack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; -print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { ($x) = pack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; -print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc"; -print "ok $test\n"; $test++; - -eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; - -eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; -$test++; - -eval { ($x) = unpack 'a/a*/b*', '212ab' }; -my $expected_x = '100001100100'; -if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; } -print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; - -# 153..156: / with # - -eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; - a3/A # Count in ASCII - C/a* # Count in a C char - C/Z # Count in a C char but skip after \0 -EOU -print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; - -$z = pack <<EOP,'string','etc'; - n/a* # Count as network short - w/A* # Count a BER integer -EOP -print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; - -print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); -print "ok $test\n"; $test++; -print 'not ' unless "1.20.300.4000" eq - sprintf "%vd", pack(" U*",1,20,300,4000); -print "ok $test\n"; $test++; -print 'not ' unless v1.20.300.4000 ne - sprintf "%vd", pack("C0U*",1,20,300,4000); -print "ok $test\n"; $test++; - diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t deleted file mode 100755 index ffbc945..0000000 --- a/contrib/perl5/t/op/pat.t +++ /dev/null @@ -1,1130 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# 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..231\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -eval 'use Config'; # Defaults assumed if this fails - -$x = "abc\ndef\n"; - -if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} -if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} - -$* = 1; -if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} -$* = 0; - -$_ = '123'; -if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} - -if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} -if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} - -if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} -if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} - -if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} -if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} - -if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} -if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} - -$_ = 'aaabbbccc'; -if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { - print "ok 13\n"; -} else { - print "not ok 13\n"; -} -if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { - print "ok 14\n"; -} else { - print "not ok 14\n"; -} - -if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} - -$_ = 'aaabccc'; -if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} -if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} - -$_ = 'aaaccc'; -if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} -if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} - -$_ = 'abcdef'; -if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} -if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} - -if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} - -if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} - -$* = 1; # test 3 only tested the optimized version--this one is for real -if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";} -$* = 0; - -$XXX{123} = 123; -$XXX{234} = 234; -$XXX{345} = 345; - -@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27'); -while ($_ = shift(@XXX)) { - ?(.*)? && (print $1,"\n"); - /not/ && reset; - /not ok 26/ && reset 'X'; -} - -while (($key,$val) = each(%XXX)) { - print "not ok 27\n"; - exit; -} - -print "ok 27\n"; - -'cde' =~ /[^ab]*/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ /$null/; -if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";} - -$_ = 'abcdefghi'; -/def/; # optimized up to cmd -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";} - -/cde/ + 0; # optimized only to spat -if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";} - -/[d][e][f]/; # not optimized -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";} - -$_ = 'now is the {time for all} good men to come to.'; -/ {([^}]*)}/; -if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} - -$_ = 'xxx {3,4} yyy zzz'; -print /( {3,4})/ ? "ok 35\n" : "not ok 35\n"; -print $1 eq ' ' ? "ok 36\n" : "not ok 36\n"; -print /( {4,})/ ? "not ok 37\n" : "ok 37\n"; -print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n"; -print $1 eq ' y' ? "ok 39\n" : "not ok 39\n"; -print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n"; -print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n"; -print /x {3,4}/ ? "not ok 42\n" : "ok 42\n"; -print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n"; - -$_ = "now is the time for all good men to come to."; -@words = /(\w+)/g; -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 44\n" - : "not ok 44\n"; - -@words = (); -while (/\w+/g) { - push(@words, $&); -} -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 45\n" - : "not ok 45\n"; - -@words = (); -pos = 0; -while (/to/g) { - push(@words, $&); -} -print join(':',@words) eq "to:to" - ? "ok 46\n" - : "not ok 46 `@words'\n"; - -pos $_ = 0; -@words = /to/g; -print join(':',@words) eq "to:to" - ? "ok 47\n" - : "not ok 47 `@words'\n"; - -$_ = "abcdefghi"; - -$pat1 = 'def'; -$pat2 = '^def'; -$pat3 = '.def.'; -$pat4 = 'abc'; -$pat5 = '^abc'; -$pat6 = 'abc$'; -$pat7 = 'ghi'; -$pat8 = '\w*ghi'; -$pat9 = 'ghi$'; - -$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0; - -for $iter (1..5) { - $t1++ if /$pat1/o; - $t2++ if /$pat2/o; - $t3++ if /$pat3/o; - $t4++ if /$pat4/o; - $t5++ if /$pat5/o; - $t6++ if /$pat6/o; - $t7++ if /$pat7/o; - $t8++ if /$pat8/o; - $t9++ if /$pat9/o; -} - -$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; -print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n"; - -$xyz = 'xyz'; -print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; - -# perl 4.009 says "unmatched ()" -eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; -print $@ eq "" ? "ok 50\n" : "not ok 50\n"; -print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; - - -$_="abcfooabcbar"; -$x=/abc/g; -print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; -$x=/abc/g; -print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; -$x=/abc/g; -print $x == 0 ? "ok 54\n" : "not ok 54\n"; -pos = 0; -$x=/ABC/gi; -print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; -$x=/ABC/gi; -print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; -$x=/ABC/gi; -print $x == 0 ? "ok 57\n" : "not ok 57\n"; -pos = 0; -$x=/abc/g; -print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; -$x=/abc/g; -print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; -$_ .= ''; -@x=/abc/g; -print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; - -$_ = "abdc"; -pos $_ = 2; -/\Gc/gc; -print "not " if (pos $_) != 2; -print "ok 61\n"; -/\Gc/g; -print "not " if defined pos $_; -print "ok 62\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 2 })b'; -print "not " if $out != 2; -print "ok 63\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 3 })c'; -print "not " if $out != 1; -print "ok 64\n"; - -$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; -@out = /(?<!foo)bar./g; -print "not " if "@out" ne 'bar2 barf'; -print "ok 65\n"; - -# Tests which depend on REG_INFTY -$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767; -$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1; - -# As well as failing if the pattern matches do unexpected things, the -# next three tests will fail if you should have picked up a lower-than- -# default value for $reg_infty from Config.pm, but have not. - -undef $@; -print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@; -print "ok 66\n"; - -undef $@; -print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@; -print "ok 67\n"; - -undef $@; -print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@; -print "ok 68\n"; - -undef $@; -eval "'aaa' =~ /a{1,$reg_infty}/"; -print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; -print "ok 69\n"; - -eval "'aaa' =~ /a{1,$reg_infty_p}/"; -print "not " - if $@ !~ m%^\QQuantifier in {,} bigger than%; -print "ok 70\n"; -undef $@; - -# Poke a couple more parse failures - -$context = 'x' x 256; -eval qq("${context}y" =~ /(?<=$context)y/); -print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; -print "ok 71\n"; - -# removed test -print "ok 72\n"; - -# Long Monsters -$test = 73; -for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory - $a = 'a' x $l; - print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/; - print "ok $test\n"; - $test++; - - print "not " if "b$a=" =~ /a$a=/; - print "ok $test\n"; - $test++; -} - -# 20000 nodes, each taking 3 words per string, and 1 per branch -$long_constant_len = join '|', 12120 .. 32645; -$long_var_len = join '|', 8120 .. 28645; -%ans = ( 'ax13876y25677lbc' => 1, - 'ax13876y25677mcb' => 0, # not b. - 'ax13876y35677nbc' => 0, # Num too big - 'ax13876y25677y21378obc' => 1, - 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] - 'ax13876y25677y21378y21378kbc' => 1, - 'ax13876y25677y21378y21378kcb' => 0, # Not b. - 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs - ); - -for ( keys %ans ) { - print "# const-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; - print "# var-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; -} - -$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; -$expect = "(bla()) ((l)u((e))) (l(e)e)"; - -sub matchit { - m/ - ( - \( - (?{ $c = 1 }) # Initialize - (?: - (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop - (?! - ) # Fail: will unwind one iteration back - ) - (?: - [^()]+ # Match a big chunk - (?= - [()] - ) # Do not try to match subchunks - | - \( - (?{ ++$c }) - | - \) - (?{ --$c }) - ) - )+ # This may not match with different subblocks - ) - (?(?{ $c != 0 }) - (?! - ) # Fail - ) # Otherwise the chunk 1 may succeed with $c>0 - /xg; -} - -@ans = (); -push @ans, $res while $res = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -@ans = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -print "not " unless "abc" =~ /^(??{"a"})b/; -print "ok $test\n"; -$test++; - -my $matched; -$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; - -@ans = @ans1 = (); -push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; -print "ok $test\n"; -$test++; - -@ans = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad -print "not " if "@ans" ne 'a/ b'; -print "ok $test\n"; -$test++; - -$code = '{$blah = 45}'; -$blah = 12; -eval { /(?$code)/ }; -print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; -print "ok $test\n"; -$test++; - -for $code ('{$blah = 45}','=xx') { - $blah = 12; - $res = eval { "xx" =~ /(?$code)/o }; - if ($code eq '=xx') { - print "#'$@','$res','$blah'\nnot " unless not $@ and $res; - } else { - print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; - } - print "ok $test\n"; - $test++; -} - -$code = '{$blah = 45}'; -$blah = 12; -eval "/(?$code)/"; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$blah = 12; -/(?{$blah = 45})/; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$x = 'banana'; -$x =~ /.a/g; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -$x =~ /.z/gc; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -sub f { - my $p = $_[0]; - return $p; -} - -$x =~ /.a/g; -print "not " unless f(pos($x)) == 4; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[t]/; -print "not " unless $^R eq '75'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[xy]/; -print "not " unless $^R eq '67' and $x eq '12'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; -print "not " unless $^R eq '79' and $x eq '12'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)'; -print "ok $test\n"; -$test++; - -$_ = 'xabcx'; -foreach $ans ('', 'c') { - /(?<=(?=a)..)((?=c)|.)/g; - print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; - print "ok $test\n"; - $test++; -} - -$_ = 'a'; -foreach $ans ('', 'a', '') { - /^|a|$/g; - print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; - print "ok $test\n"; - $test++; -} - -sub prefixify { - my($v,$a,$b,$res) = @_; - $v =~ s/\Q$a\E/$b/; - print "not " unless $res eq $v; - print "ok $test\n"; - $test++; -} -prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); -prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); - -$_ = 'var="foo"'; -/(\")/; -print "not " unless $1 and /$1/; -print "ok $test\n"; -$test++; - -$a=qr/(?{++$b})/; -$b = 7; -/$a$a/; -print "not " unless $b eq '9'; -print "ok $test\n"; -$test++; - -$c="$a"; -/$a$a/; -print "not " unless $b eq '11'; -print "ok $test\n"; -$test++; - -{ - use re "eval"; - /$a$c$a/; - print "not " unless $b eq '14'; - print "ok $test\n"; - $test++; - - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; - - - no re "eval"; - $match = eval { /$a$c$a/ }; - print "not " - unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match; - print "ok $test\n"; - $test++; -} - -{ - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; -} - -{ - package aa; - $c = 2; - $::c = 3; - '' =~ /(?{ $c = 4 })/; - print "not " unless $c == 4; -} -print "ok $test\n"; -$test++; -print "not " unless $c == 3; -print "ok $test\n"; -$test++; - -sub must_warn_pat { - my $warn_pat = shift; - return sub { print "not " unless $_[0] =~ /$warn_pat/ } -} - -sub must_warn { - my ($warn_pat, $code) = @_; - local %SIG; - eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; - print "ok $test\n"; - $test++; -} - - -sub make_must_warn { - my $warn_pat = shift; - return sub { must_warn(must_warn_pat($warn_pat)) } -} - -my $for_future = make_must_warn('reserved for future extensions'); - -&$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); - -#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -# test if failure of patterns returns empty list -$_ = 'aaa'; -@_ = /bbb/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /bbb/g; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/g; -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++; - -eval { $+[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { $-[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @+ = (7, 6, 5); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @- = qw(foo bar); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -/.(a)(ba*)?/; -print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; -print "ok $test\n"; -$test++; - -$_ = 'aaa'; -pos = 1; -@a = /\Ga/g; -print "not " unless "@a" eq "a a"; -print "ok $test\n"; -$test++; - -$str = 'abcde'; -pos $str = 2; - -print "not " if $str =~ /^\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^.\G/; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /^..\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^...\G/; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /.\G./ and $& eq 'bc'; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /\G../ and $& eq 'cd'; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos $str = undef; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; -print "ok $test\n"; -$test++; - -$_ = $str; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos eq 3; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos = undef; -1 while /b(?{$foo = $_; $bar = pos})c/g; -print "#'$str','$foo','$bar'\nnot " - unless $foo eq 'abcde' and $bar eq 2 and not defined pos; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -$_ = 'abcde|abcde'; -print "#'$str','$foo','$bar','$_'\nnot " - unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' - and $bar eq 8 and $_ eq 'axde|axde'; -print "ok $test\n"; -$test++; - -@res = (); -# List context: -$_ = 'abcde|abcde'; -@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; -print "ok $test\n"; -$test++; - -@res = (); -@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq - "'' 'ab' 'cde|abcde' " . - "'' 'abc' 'de|abcde' " . - "'abcd' 'e|' 'abcde' " . - "'abcde|' 'ab' 'cde' " . - "'abcde|' 'abc' 'de'" ; -print "ok $test\n"; -$test++; - -#Some more \G anchor checks -$foo='aabbccddeeffgg'; - -pos($foo)=1; - -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'ab'); -print "ok $test\n"; -$test++; - -pos($foo) += 1; -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'cc'); -print "ok $test\n"; -$test++; - -pos($foo) += 1; -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'de'); -print "ok $test\n"; -$test++; - -print "not " unless $foo =~ /\Gef/g; -print "ok $test\n"; -$test++; - -undef pos $foo; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'aa'); -print "ok $test\n"; -$test++; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'bb'); -print "ok $test\n"; -$test++; - -pos($foo)=5; -$foo=~/\G(..)/g; -print "not " unless($1 eq 'cd'); -print "ok $test\n"; -$test++; - -$_='123x123'; -@res = /(\d*|x)/g; -print "not " unless('123||x|123|' eq join '|', @res); -print "ok $test\n"; -$test++; - -# see if matching against temporaries (created via pp_helem()) is safe -{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; -print "$1\n"; -$test++; - -# See if $i work inside (?{}) in the presense of saved substrings and -# changing $_ -@a = qw(foo bar); -@b = (); -s/(\w)(?{push @b, $1})/,$1,/g for @a; - -print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); -print "ok $test\n"; -$test++; - -print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); -print "ok $test\n"; -$test++; - -$brackets = qr{ - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; - -"{{}" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ m/((??{ $brackets }))/; -print "not " unless $1 eq "{ and }"; -print "ok $test\n"; -$test++; - -$_ = "a-a\nxbb"; -pos=1; -m/^-.*bb/mg and print "not "; -print "ok $test\n"; -$test++; - -$text = "aaXbXcc"; -pos($text)=0; -$text =~ /\GXb*X/g and print 'not '; -print "ok $test\n"; -$test++; - -$text = "xA\n" x 500; -$text =~ /^\s*A/m and print 'not '; -print "ok $test\n"; -$test++; - -$text = "abc dbf"; -@res = ($text =~ /.*?(b).*?\b/g); -"@res" eq 'b b' or print 'not '; -print "ok $test\n"; -$test++; - -@a = map chr,0..255; - -@b = grep(/\S/,@a); -@c = grep(/[^\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\S/,@a); -@c = grep(/[\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[^\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[^\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[^\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[^\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[^\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -# see if backtracking optimization works correctly -"\n\n" =~ /\n $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n* $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n+ $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -[] =~ /^ARRAY/ or print "# [] \nnot "; -print "ok $test\n"; -$test++; - -eval << 'EOE'; -{ - package S; - use overload '""' => sub { 'Object S' }; - sub new { bless [] } -} -$a = 'S'->new; -EOE - -$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; -print "ok $test\n"; -$test++; - -# test result of match used as match (!) -'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -$w = 0; -{ - local $SIG{__WARN__} = sub { $w = 1 }; - local $^W = 1; - $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; -} -print $w ? "not " : "", "ok $test\n"; -$test++; - -my %space = ( spc => " ", - tab => "\t", - cr => "\r", - lf => "\n", - ff => "\f", -# There's no \v but the vertical tabulator seems miraculously -# be 11 both in ASCII and EBCDIC. - vt => chr(11), - false => "space" ); - -my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; -my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; -my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; - -print "not " unless "@space0" eq "cr ff lf spc tab"; -print "ok $test # @space0\n"; -$test++; - -print "not " unless "@space1" eq "cr ff lf spc tab vt"; -print "ok $test # @space1\n"; -$test++; - -print "not " unless "@space2" eq "spc tab"; -print "ok $test # @space2\n"; -$test++; - -# bugid 20001021.005 - this caused a SEGV -print "not " unless undef =~ /^([^\/]*)(.*)$/; -print "ok $test\n"; -$test++; - -{ - # japhy -- added 03/03/2001 - () = (my $str = "abc") =~ /(...)/; - $str = "def"; - print "not " if $1 ne "abc"; - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t deleted file mode 100755 index f3bc23c..0000000 --- a/contrib/perl5/t/op/pos.t +++ /dev/null @@ -1,23 +0,0 @@ -#!./perl - -print "1..4\n"; - -$x='banana'; -$x=~/.a/g; -if (pos($x)==2) {print "ok 1\n"} else {print "not ok 1\n";} - -$x=~/.z/gc; -if (pos($x)==2) {print "ok 2\n"} else {print "not ok 2\n";} - -sub f { my $p=$_[0]; return $p } - -$x=~/.a/g; -if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} - -# Is pos() set inside //g? (bug id 19990615.008) -$x = "test string?"; $x =~ s/\w/pos($x)/eg; -print "not " unless $x eq "0123 5678910?"; -print "ok 4\n"; - - - diff --git a/contrib/perl5/t/op/push.t b/contrib/perl5/t/op/push.t deleted file mode 100755 index a67caed..0000000 --- a/contrib/perl5/t/op/push.t +++ /dev/null @@ -1,56 +0,0 @@ -#!./perl - -# $RCSfile: push.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:13 $ - -@tests = split(/\n/, <<EOF); -0 3, 0 1 2, 3 4 5 6 7 -0 0 a b c, , a b c 0 1 2 3 4 5 6 7 -8 0 a b c, , 0 1 2 3 4 5 6 7 a b c -7 0 6.5, , 0 1 2 3 4 5 6 6.5 7 -1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7 -0 1 a, 0, a 1 2 3 4 5 6 7 -1 6 x y z, 1 2 3 4 5 6, 0 x y z 7 -0 7 x y z, 0 1 2 3 4 5 6, x y z 7 -1 7 x y z, 1 2 3 4 5 6 7, 0 x y z -4, 4 5 6 7, 0 1 2 3 --4, 4 5 6 7, 0 1 2 3 -EOF - -print "1..", 4 + @tests, "\n"; -die "blech" unless @tests; - -@x = (1,2,3); -push(@x,@x); -if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} -push(@x,4); -if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} - -# test for push/pop intuiting @ on array -push(x,3); -if (join(':',@x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n";} -pop(x); -if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 4\n";} else {print "not ok 4\n";} - -$test = 5; -foreach $line (@tests) { - ($list,$get,$leave) = split(/,\t*/,$line); - ($pos, $len, @list) = split(' ',$list); - @get = split(' ',$get); - @leave = split(' ',$leave); - @x = (0,1,2,3,4,5,6,7); - if (defined $len) { - @got = splice(@x, $pos, $len, @list); - } - else { - @got = splice(@x, $pos); - } - if (join(':',@got) eq join(':',@get) && - join(':',@x) eq join(':',@leave)) { - print "ok ",$test++,"\n"; - } - else { - print "not ok ",$test++," got: @got == @get left: @x == @leave\n"; - } -} - -1; # this file is require'd by lib/tie-stdpush.t diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t deleted file mode 100755 index d811f06..0000000 --- a/contrib/perl5/t/op/pwent.t +++ /dev/null @@ -1,170 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../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 the PW filehandle should be open and full of juicy password entries. - -print "1..2\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; - -setpwent(); -while (<PW>) { - chomp; - # LIMIT -1 so that users with empty shells don't fall off - my @s = split /:/, $_, -1; - my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); - if ($^O eq 'darwin') { - ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; - } else { - ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; - } - next if /^\+/; # ignore NIS includes - if (@s) { - push @{ $seen{$name_s} }, $.; - } 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 || ($^O eq 'darwin' && @s == 10)) { - @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++; -} -endpwent(); - -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"; - -# Test both the scalar and list contexts. - -my @pw1; - -setpwent(); -for (1..$max) { - my $pw = scalar getpwent(); - last unless defined $pw; - push @pw1, $pw; -} -endpwent(); - -my @pw2; - -setpwent(); -for (1..$max) { - my ($pw) = (getpwent()); - last unless defined $pw; - push @pw2, $pw; -} -endpwent(); - -print "not " unless "@pw1" eq "@pw2"; -print "ok ", $tst++, "\n"; - -close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t deleted file mode 100755 index ea62ed8..0000000 --- a/contrib/perl5/t/op/quotemeta.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..17\n"; - -if ($Config{ebcdic} eq 'define') { - $_=join "", map chr($_), 129..233; - - # 105 characters - 52 letters = 53 backslashes - # 105 characters + 53 backslashes = 158 characters - $_= quotemeta $_; - 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"} -} - -if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} - -print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n"; -print "aA\LbB\UcC\EdD" eq "aAbbCCdD" ? "ok 5\n" : "not ok 5 \n"; -print "\L\upERL" eq "Perl" ? "ok 6\n" : "not ok 6 \n"; -print "\u\LpERL" eq "Perl" ? "ok 7\n" : "not ok 7 \n"; -print "\U\lPerl" eq "pERL" ? "ok 8\n" : "not ok 8 \n"; -print "\l\UPerl" eq "pERL" ? "ok 9\n" : "not ok 9 \n"; -print "\u\LpE\Q#X#\ER\EL" eq "Pe\\#x\\#rL" ? "ok 10\n" : "not ok 10 \n"; -print "\l\UPe\Q!x!\Er\El" eq "pE\\!X\\!Rl" ? "ok 11\n" : "not ok 11 \n"; -print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; -print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; -print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; -print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; - -print length(quotemeta("\x{263a}")) == 1 ? "ok 16\n" : "not ok 16\n"; -print quotemeta("\x{263a}") eq "\x{263a}" ? "ok 17\n" : "not ok 17\n"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t deleted file mode 100755 index 83186ae..0000000 --- a/contrib/perl5/t/op/rand.t +++ /dev/null @@ -1,359 +0,0 @@ -#!./perl - -# From Tom Phoenix <rootbeer@teleport.com> 22 Feb 1997 -# Based upon a test script by kgb@ast.cam.ac.uk (Karl Glazebrook) - -# Looking for the hints? You're in the right place. -# The hints are near each test, so search for "TEST #", where -# the pound sign is replaced by the number of the test. - -# I'd like to include some more robust tests, but anything -# too subtle to be detected here would require a time-consuming -# test. Also, of course, we're here to detect only flaws in Perl; -# if there are flaws in the underlying system rand, that's not -# our responsibility. But if you want better tests, see -# The Art of Computer Programming, Donald E. Knuth, volume 2, -# chapter 3. ISBN 0-201-03822-6 (v. 2) - -BEGIN { - chdir "t" if -d "t"; - @INC = '../lib'; -} - -use strict; -use Config; - -print "1..11\n"; - -srand; # Shouldn't need this with 5.004... - # But I'll include it now and test for - # whether we needed it later. - -my $reps = 1000; # How many times to try rand each time. - # May be changed, but should be over 500. - # The more the better! (But slower.) - -sub bits ($) { - # Takes a small integer and returns the number of one-bits in it. - my $total; - my $bits = sprintf "%o", $_[0]; - while (length $bits) { - $total += (0,1,1,2,1,2,2,3)[chop $bits]; # Oct to bits - } - $total; -} - -# First, let's see whether randbits is set right -{ - my($max, $min, $sum); # Characteristics of rand - my($off, $shouldbe); # Problems with randbits - my($dev, $bits); # Number of one bits - my $randbits = $Config{randbits}; - $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! - # But that should never be the case... I hope. - # Note: If you change this, you must adapt the - # formula for absolute standard deviation, below. - $max = $n if $n > $max; - $min = $n if $n < $min; - } - - - # Hints for TEST 1 - # - # This test checks for one of Perl's most frequent - # mis-configurations. Your system's documentation - # for rand(2) should tell you what value you need - # for randbits. Usually the diagnostic message - # has the right value as well. Just fix it and - # recompile, and you'll usually be fine. (The main - # reason that the diagnostic message might get the - # wrong value is that Config.pm is incorrect.) - # - 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"; - print "# have taken over your computer. For starters, see about\n"; - print "# trying a better value for randbits, probably smaller.\n"; - # If that isn't the problem, we'll have - # to put d_martians into Config.pm - print "# Skipping remaining tests until randbits is fixed.\n"; - exit; - } - - $off = log($max) / log(2); # log2 - $off = int($off) + ($off > 0); # Next more positive int - if ($off) { - $shouldbe = $Config{randbits} + $off; - 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. - print "# Skipping remaining tests until randbits is fixed.\n"; - exit; - } else { - print "ok 1\n"; - } - - # Hints for TEST 2 - # - # This should always be true: 0 <= rand(1) < 1 - # If this test is failing, something is seriously wrong, - # either in perl or your system's rand function. - # - if ($min < 0 or $max >= 1) { # Slightly redundant... - print "not ok 2\n"; - print "# min too low\n" if $min < 0; - print "# max too high\n" if $max >= 1; - } else { - print "ok 2\n"; - } - - # Hints for TEST 3 - # - # This is just a crude test. The average number produced - # by rand should be about one-half. But once in a while - # it will be relatively far away. Note: This test will - # occasionally fail on a perfectly good system! - # See the hints for test 4 to see why. - # - $sum /= $reps; - if ($sum < 0.4 or $sum > 0.6) { - print "not ok 3\n# Average random number is far from 0.5\n"; - } else { - print "ok 3\n"; - } - - # Hints for TEST 4 - # - # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - # This test will fail .1% of the time on a normal system. - # also - # This test asks you to see these hints 100% of the time! - # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - # - # There is probably no reason to be alarmed that - # something is wrong with your rand function. But, - # if you're curious or if you can't help being - # alarmed, keep reading. - # - # This is a less-crude test than test 3. But it has - # the same basic flaw: Unusually distributed random - # values should occasionally appear in every good - # random number sequence. (If you flip a fair coin - # twenty times every day, you'll see it land all - # heads about one time in a million days, on the - # average. That might alarm you if you saw it happen - # on the first day!) - # - # So, if this test failed on you once, run it a dozen - # times. If it keeps failing, it's likely that your - # rand is bogus. If it keeps passing, it's likely - # that the one failure was bogus. If it's a mix, - # read on to see about how to interpret the tests. - # - # The number printed in square brackets is the - # standard deviation, a statistical measure - # of how unusual rand's behavior seemed. It should - # fall in these ranges with these *approximate* - # probabilities: - # - # under 1 68.26% of the time - # 1-2 27.18% of the time - # 2-3 4.30% of the time - # over 3 0.26% of the time - # - # If the numbers you see are not scattered approximately - # (not exactly!) like that table, check with your vendor - # to find out what's wrong with your rand. Or with this - # algorithm. :-) - # - # Calculating absoulute standard deviation for number of bits set - # (eight bits per rep) - $dev = abs ($bits - $reps * 4) / sqrt($reps * 2); - - if ($dev < 1.96) { - print "ok 4\n"; # 95% of the time. - print "# Your rand seems fine. If this test failed\n"; - print "# previously, you may want to run it again.\n"; - } elsif ($dev < 2.575) { - print "ok 4\n# In here about 4% of the time. Hmmm...\n"; - print "# This is ok, but suspicious. But it will happen\n"; - print "# one time out of 25, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } elsif ($dev < 3.3) { - print "ok 4\n# In this range about 1% of the time.\n"; - print "# This is very suspicious. It will happen only\n"; - print "# about one time out of 100, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } elsif ($dev < 3.9) { - print "not ok 4\n# In this range very rarely.\n"; - print "# This is VERY suspicious. It will happen only\n"; - print "# about one time out of 1000, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } else { - print "not ok 4\n# Seriously whacked.\n"; - print "# This is VERY VERY suspicious.\n"; - print "# Your rand seems to be bogus.\n"; - } - print "#\n# If you are having random number troubles,\n"; - print "# see the hints within the test script for more\n"; - printf "# information on why this might fail. [ %.3f ]\n", $dev; -} - -{ - srand; # These three lines are for test 7 - my $time = time; # It's just faster to do them here. - my $rand = join ", ", rand, rand, rand; - - # Hints for TEST 5 - # - # This test checks that the argument to srand actually - # sets the seed for generating random numbers. - # - srand(3.14159); - my $r = rand; - srand(3.14159); - if (rand != $r) { - print "not ok 5\n"; - print "# srand is not consistent.\n"; - } else { - print "ok 5\n"; - } - - # Hints for TEST 6 - # - # This test just checks that the previous one didn't - # give us false confidence! - # - if (rand == $r) { - print "not ok 6\n"; - print "# rand is now unchanging!\n"; - } else { - print "ok 6\n"; - } - - # Hints for TEST 7 - # - # This checks that srand without arguments gives - # different sequences each time. Note: You shouldn't - # be calling srand more than once unless you know - # what you're doing! But if this fails on your - # system, run perlbug and let the developers know - # what other sources of randomness srand should - # tap into. - # - while ($time == time) { } # Wait for new second, just in case. - srand; - if ((join ", ", rand, rand, rand) eq $rand) { - print "not ok 7\n"; - print "# srand without args isn't varying.\n"; - } else { - print "ok 7\n"; - } -} - -# Now, let's see whether rand accepts its argument -{ - my($max, $min); - $max = $min = rand(100); - for (1..$reps) { - my $n = rand(100); - $max = $n if $n > $max; - $min = $n if $n < $min; - } - - # Hints for TEST 8 - # - # This test checks to see that rand(100) really falls - # within the range 0 - 100, and that the numbers produced - # have a reasonably-large range among them. - # - if ($min < 0 or $max >= 100 or ($max - $min) < 65) { - print "not ok 8\n"; - print "# min too low\n" if $min < 0; - print "# max too high\n" if $max >= 100; - print "# range too narrow\n" if ($max - $min) < 65; - } else { - print "ok 8\n"; - } - - # Hints for TEST 9 - # - # This test checks that rand without an argument - # is equivalent to rand(1). - # - $_ = 12345; # Just for fun. - srand 12345; - my $r = rand; - srand 12345; - if (rand(1) == $r) { - print "ok 9\n"; - } else { - print "not ok 9\n"; - print "# rand without arguments isn't rand(1)!\n"; - } - - # Hints for TEST 10 - # - # This checks that rand without an argument is not - # rand($_). (In case somebody got overzealous.) - # - if ($r >= 1) { - print "not ok 10\n"; - print "# rand without arguments isn't under 1!\n"; - } else { - print "ok 10\n"; - } -} - -# Hints for TEST 11 -# -# This test checks whether Perl called srand for you. This should -# be the case in version 5.004 and later. Note: You must still -# call srand if your code might ever be run on a pre-5.004 system! -# -AUTOSRAND: -{ - unless ($Config{d_fork}) { - # Skip this test. It's not likely to be system-specific, anyway. - print "ok 11\n# Skipping this test on this platform.\n"; - last; - } - - my($pid, $first); - for (1..5) { - my $PERL = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : './perl'); - $pid = open PERL, qq[$PERL -e "print rand"|]; - die "Couldn't pipe from perl: $!" unless defined $pid; - if (defined $first) { - if ($first ne <PERL>) { - print "ok 11\n"; - last AUTOSRAND; - } - } else { - $first = <PERL>; - } - close PERL or die "perl returned error code $?"; - } - print "not ok 11\n# srand isn't being autocalled.\n"; -} diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t deleted file mode 100755 index e8aecf5..0000000 --- a/contrib/perl5/t/op/range.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -print "1..15\n"; - -print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; - -@foo = (1,2,3,4,5,6,7,8,9); -@foo[2..4] = ('c','d','e'); - -print join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n"; - -@bar[2..4] = ('c','d','e'); -print join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n"; - -($a,@bcd[0..2],$e) = ('a','b','c','d','e'); -print join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n"; - -$x = 0; -for (1..100) { - $x += $_; -} -print $x == 5050 ? "ok 5\n" : "not ok 5 $x\n"; - -$x = 0; -for ((100,2..99,1)) { - $x += $_; -} -print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n"; - -$x = join('','a'..'z'); -print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n"; - -@x = 'A'..'ZZ'; -print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n"; - -@x = '09' .. '08'; # should produce '09', '10',... '99' (strange but true) -print "not " unless join(",", @x) eq - join(",", map {sprintf "%02d",$_} 9..99); -print "ok 9\n"; - -# same test with foreach (which is a separate implementation) -@y = (); -foreach ('09'..'08') { - push(@y, $_); -} -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"; -} - -# Should use magical autoinc only when both are strings -print "not " unless 0 == (() = "0"..-1); -print "ok 14\n"; - -for my $x ("0"..-1) { - print "not "; -} -print "ok 15\n"; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests deleted file mode 100644 index 6477d67..0000000 --- a/contrib/perl5/t/op/re_tests +++ /dev/null @@ -1,786 +0,0 @@ -abc abc y $& abc -abc xbc n - - -abc axc n - - -abc abx n - - -abc xabcy y $& abc -abc ababc y $& abc -ab*c abc y $& abc -ab*bc abc y $& abc -ab*bc abbc y $& abbc -ab*bc abbbbc y $& abbbbc -.{1} abbbbc y $& a -.{3,4} abbbbc y $& abbb -ab{0,}bc abbbbc y $& abbbbc -ab+bc abbc y $& abbc -ab+bc abc n - - -ab+bc abq n - - -ab{1,}bc abq n - - -ab+bc abbbbc y $& abbbbc -ab{1,}bc abbbbc y $& abbbbc -ab{1,3}bc abbbbc y $& abbbbc -ab{3,4}bc abbbbc y $& abbbbc -ab{4,5}bc abbbbc n - - -ab?bc abbc y $& abbc -ab?bc abc y $& abc -ab{0,1}bc abc y $& abc -ab?bc abbbbc n - - -ab?c abc y $& abc -ab{0,1}c abc y $& abc -^abc$ abc y $& abc -^abc$ abcc n - - -^abc abcc y $& abc -^abc$ aabc n - - -abc$ aabc y $& abc -abc$ aabcd n - - -^ abc y $& -$ abc y $& -a.c abc y $& abc -a.c axc y $& axc -a.*c axyzc y $& axyzc -a.*c axyzd n - - -a[bc]d abc n - - -a[bc]d abd y $& abd -a[b-d]e abd n - - -a[b-d]e ace y $& ace -a[b-d] aac y $& ac -a[-b] a- y $& a- -a[b-] a- y $& a- -a[b-a] - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ -a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ -a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / -a] a] y $& a] -a[]]b a]b y $& a]b -a[^bc]d aed y $& aed -a[^bc]d abd n - - -a[^-b]c adc y $& adc -a[^-b]c a-c n - - -a[^]b]c a]c n - - -a[^]b]c adc y $& adc -\ba\b a- y - - -\ba\b -a y - - -\ba\b -a- y - - -\by\b xy n - - -\by\b yz n - - -\by\b xyz n - - -\Ba\B a- n - - -\Ba\B -a n - - -\Ba\B -a- n - - -\By\b xy y - - -\by\B yz y - - -\By\B xyz y - - -\w a y - - -\w - n - - -\W a n - - -\W - y - - -a\sb a b y - - -a\sb a-b n - - -a\Sb a b n - - -a\Sb a-b y - - -\d 1 y - - -\d - n - - -\D 1 n - - -\D - y - - -[\w] a y - - -[\w] - n - - -[\W] a n - - -[\W] - y - - -a[\s]b a b y - - -a[\s]b a-b n - - -a[\S]b a b n - - -a[\S]b a-b y - - -[\d] 1 y - - -[\d] - n - - -[\D] 1 n - - -[\D] - y - - -ab|cd abc y $& ab -ab|cd abcd y $& ab -()ef def y $&-$1 ef- -*a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ -(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ -$b b n - - -a\ - c - Search pattern not terminated -a\(b a(b y $&-$1 a(b- -a\(*b ab y $& ab -a\(*b a((b y $& a((b -a\\b a\b y $& a\b -abc) - c - Unmatched ) before HERE mark in regex m/abc) << HERE / -(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ -((a)) abc y $&-$1-$2 a-a-a -(a)b(c) abc y $&-$1-$2 abc-a-c -a+b+c aabbabc y $& abc -a{1,}b{1,}c aabbabc y $& abc -a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE / -a.+?c abcabc y $& abc -(a+|b)* ab y $&-$1 ab-b -(a+|b){0,} ab y $&-$1 ab-b -(a+|b)+ ab y $&-$1 ab-b -(a+|b){1,} ab y $&-$1 ab-b -(a+|b)? ab y $&-$1 a-a -(a+|b){0,1} ab y $&-$1 a-a -)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ -[^ab]* cde y $& cde -abc n - - -a* y $& -([abc])*d abbbcd y $&-$1 abbbcd-c -([abc])*bcd abcd y $&-$1 abcd-a -a|b|c|d|e e y $& e -(a|b|c|d|e)f ef y $&-$1 ef-e -abcd*efg abcdefg y $& abcdefg -ab* xabyabbbz y $& ab -ab* xayabbbz y $& a -(ab|cd)e abcde y $&-$1 cde-cd -[abhgefdc]ij hij y $& hij -^(ab|cd)e abcde n x$1y xy -(abc|)ef abcdef y $&-$1 ef- -(a|b)c*d abcd y $&-$1 bcd-b -(ab|ab*)bc abc y $&-$1 abc-a -a([bc]*)c* abc y $&-$1 abc-bc -a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d -a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d -a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd -a[bcd]*dcdcde adcdcde y $& adcdcde -a[bcd]+dcdcde adcdcde n - - -(ab|a)b*c abc y $&-$1 abc-ab -((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d -[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha -^a(bc+|b[eh])g|.h$ abh y $&-$1 bh- -(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz- -(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j -(bc+d$|ef*g.|h?i(j|k)) effg n - - -(bc+d$|ef*g.|h?i(j|k)) bcdd 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))))))))))${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 -(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de -\((.*), (.*)\) (a, b) y ($2, $1) (b, a) -[k] ab n - - -abcd abcd y $&-\$&-\\$& abcd-$&-\abcd -a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc -a[-]?c ac y $& ac -(abc)\1 abcabc y $1 abc -([a-c]*)\1 abcabc y $1 abc -\1 - c - Reference to nonexistent group -\2 - c - Reference to nonexistent group -(a)|\1 a y - - -(a)|\1 x n - - -(a)|\2 - c - Reference to nonexistent group -(([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b -(([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c -((\3|b)\2(a)x)+ aaxabxbaxbbx n - - -((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a -((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a -'abc'i ABC y $& ABC -'abc'i XBC n - - -'abc'i AXC n - - -'abc'i ABX n - - -'abc'i XABCY y $& ABC -'abc'i ABABC y $& ABC -'ab*c'i ABC y $& ABC -'ab*bc'i ABC y $& ABC -'ab*bc'i ABBC y $& ABBC -'ab*?bc'i ABBBBC y $& ABBBBC -'ab{0,}?bc'i ABBBBC y $& ABBBBC -'ab+?bc'i ABBC y $& ABBC -'ab+bc'i ABC n - - -'ab+bc'i ABQ n - - -'ab{1,}bc'i ABQ n - - -'ab+bc'i ABBBBC y $& ABBBBC -'ab{1,}?bc'i ABBBBC y $& ABBBBC -'ab{1,3}?bc'i ABBBBC y $& ABBBBC -'ab{3,4}?bc'i ABBBBC y $& ABBBBC -'ab{4,5}?bc'i ABBBBC n - - -'ab??bc'i ABBC y $& ABBC -'ab??bc'i ABC y $& ABC -'ab{0,1}?bc'i ABC y $& ABC -'ab??bc'i ABBBBC n - - -'ab??c'i ABC y $& ABC -'ab{0,1}?c'i ABC y $& ABC -'^abc$'i ABC y $& ABC -'^abc$'i ABCC n - - -'^abc'i ABCC y $& ABC -'^abc$'i AABC n - - -'abc$'i AABC y $& ABC -'^'i ABC y $& -'$'i ABC y $& -'a.c'i ABC y $& ABC -'a.c'i AXC y $& AXC -'a.*?c'i AXYZC y $& AXYZC -'a.*c'i AXYZD n - - -'a[bc]d'i ABC n - - -'a[bc]d'i ABD y $& ABD -'a[b-d]e'i ABD n - - -'a[b-d]e'i ACE y $& ACE -'a[b-d]'i AAC y $& AC -'a[-b]'i A- y $& A- -'a[b-]'i A- y $& A- -'a[b-a]'i - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ -'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ -'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / -'a]'i A] y $& A] -'a[]]b'i A]B y $& A]B -'a[^bc]d'i AED y $& AED -'a[^bc]d'i ABD n - - -'a[^-b]c'i ADC y $& ADC -'a[^-b]c'i A-C n - - -'a[^]b]c'i A]C n - - -'a[^]b]c'i ADC y $& ADC -'ab|cd'i ABC y $& AB -'ab|cd'i ABCD y $& AB -'()ef'i DEF y $&-$1 EF- -'*a'i - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ -'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ -'$b'i B n - - -'a\'i - c - Search pattern not terminated -'a\(b'i A(B y $&-$1 A(B- -'a\(*b'i AB y $& AB -'a\(*b'i A((B y $& A((B -'a\\b'i A\B y $& A\B -'abc)'i - c - Unmatched ) before HERE mark in regex m/abc) << HERE / -'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ -'((a))'i ABC y $&-$1-$2 A-A-A -'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C -'a+b+c'i AABBABC y $& ABC -'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - Nested quantifiers before HERE mark in regex m/a** << HERE / -'a.+?c'i ABCABC y $& ABC -'a.*?c'i ABCABC y $& ABC -'a.{0,5}?c'i ABCABC y $& ABC -'(a+|b)*'i AB y $&-$1 AB-B -'(a+|b){0,}'i AB y $&-$1 AB-B -'(a+|b)+'i AB y $&-$1 AB-B -'(a+|b){1,}'i AB y $&-$1 AB-B -'(a+|b)?'i AB y $&-$1 A-A -'(a+|b){0,1}'i AB y $&-$1 A-A -'(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ -'[^ab]*'i CDE y $& CDE -'abc'i n - - -'a*'i y $& -'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C -'([abc])*bcd'i ABCD y $&-$1 ABCD-A -'a|b|c|d|e'i E y $& E -'(a|b|c|d|e)f'i EF y $&-$1 EF-E -'abcd*efg'i ABCDEFG y $& ABCDEFG -'ab*'i XABYABBBZ y $& AB -'ab*'i XAYABBBZ y $& A -'(ab|cd)e'i ABCDE y $&-$1 CDE-CD -'[abhgefdc]ij'i HIJ y $& HIJ -'^(ab|cd)e'i ABCDE n x$1y XY -'(abc|)ef'i ABCDEF y $&-$1 EF- -'(a|b)c*d'i ABCD y $&-$1 BCD-B -'(ab|ab*)bc'i ABC y $&-$1 ABC-A -'a([bc]*)c*'i ABC y $&-$1 ABC-BC -'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D -'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D -'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD -'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE -'a[bcd]+dcdcde'i ADCDCDE n - - -'(ab|a)b*c'i ABC y $&-$1 ABC-AB -'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D -'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA -'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH- -'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ- -'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J -'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - - -'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - - -'(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))))))))))${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 -'multiple words of text'i UH-UH n - - -'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS -'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE -'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A) -'[k]'i AB n - - -'abcd'i ABCD y $&-\$&-\\$& ABCD-$&-\ABCD -'a(bc)d'i ABCD y $1-\$1-\\$1 BC-$1-\BC -'a[-]?c'i AC y $& AC -'(abc)\1'i ABCABC y $1 ABC -'([a-c]*)\1'i ABCABC y $1 ABC -a(?!b). abad y $& ad -a(?=d). abad y $& ad -a(?=c|d). abad y $& ad -a(?:b|c|d)(.) ace y $1 e -a(?:b|c|d)*(.) ace y $1 e -a(?:b|c|d)+?(.) ace y $1 e -a(?:b|c|d)+?(.) acdbcdbe y $1 d -a(?:b|c|d)+(.) acdbcdbe y $1 e -a(?:b|c|d){2}(.) acdbcdbe y $1 b -a(?:b|c|d){4,5}(.) acdbcdbe y $1 b -a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d -((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar -:(?: - c - Sequence (? incomplete -a(?:b|c|d){6,7}(.) acdbcdbe y $1 e -a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e -a(?:b|c|d){5,6}(.) acdbcdbe y $1 e -a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b -a(?:b|c|d){5,7}(.) acdbcdbe y $1 e -a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b -a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce -^(.+)?B AB y $1 A -^([^a-z])|(\^)$ . y $1 . -^[<>]& <&OUT y $& <& -^(a\1?){4}$ aaaaaaaaaa y $1 aaaa -^(a\1?){4}$ aaaaaaaaa n - - -^(a\1?){4}$ aaaaaaaaaaa n - - -^(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 - - -(?<=a)b b n - - -(?<!c)b ab y $& b -(?<!c)b cb n - - -(?<!c)b b y - - -(?<!c)b b y $& b -(?<%)b - c - Sequence (?<%...) not recognized before HERE mark in regex m/(?<% << HERE )b/ -(?:..)*a aba y $& aba -(?:..)*?a aba y $& a -^(?:b|a(?=(.)))*\1 abc y $& ab -^(){3,5} abc y a$1 a -^(a+)*ax aax y $1 a -^((a|b)+)*ax aax y $1 a -^((a|bc)+)*ax aax y $1 a -(a|x)*ab cab y y$1 y -(a)*ab cab y y$1 y -(?:(?i)a)b ab y $& ab -((?i)a)b ab y $&:$1 ab:a -(?:(?i)a)b Ab y $& Ab -((?i)a)b Ab y $&:$1 Ab:A -(?:(?i)a)b aB n - - -((?i)a)b aB n - - -(?i:a)b ab y $& ab -((?i:a))b ab y $&:$1 ab:a -(?i:a)b Ab y $& Ab -((?i:a))b Ab y $&:$1 Ab:A -(?i:a)b aB n - - -((?i:a))b aB n - - -'(?:(?-i)a)b'i ab y $& ab -'((?-i)a)b'i ab y $&:$1 ab:a -'(?:(?-i)a)b'i aB y $& aB -'((?-i)a)b'i aB y $&:$1 aB:a -'(?:(?-i)a)b'i Ab n - - -'((?-i)a)b'i Ab n - - -'(?:(?-i)a)b'i aB y $& aB -'((?-i)a)b'i aB y $1 a -'(?:(?-i)a)b'i AB n - - -'((?-i)a)b'i AB n - - -'(?-i:a)b'i ab y $& ab -'((?-i:a))b'i ab y $&:$1 ab:a -'(?-i:a)b'i aB y $& aB -'((?-i:a))b'i aB y $&:$1 aB:a -'(?-i:a)b'i Ab n - - -'((?-i:a))b'i Ab n - - -'(?-i:a)b'i aB y $& aB -'((?-i:a))b'i aB y $1 a -'(?-i:a)b'i AB n - - -'((?-i:a))b'i AB n - - -'((?-i:a.))b'i a\nB n - - -'((?s-i:a.))b'i a\nB y $1 a\n -'((?s-i:a.))b'i B\nB n - - -(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b))) cabbbb y $& cabbbb -(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb))) caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb y $& caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb -'(ab)\d\1'i Ab4ab y $1 Ab -'(ab)\d\1'i ab4Ab y $1 ab -foo\w*\d{4}baz foobar1234baz y $& foobar1234baz -a(?{})b cabd y $& ab -a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ -a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ -a(?{}})b - c - -a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ -a(?{"\{"})b cabd y $& ab -a(?{"{"}})b - c - Unmatched right curly bracket -a(?{$bl="\{"}).b caxbd y $bl { -x(~~)*(?:(?:F)?)? x~~ y - - -^a(?#xxx){3}c aaac y $& aaac -'^a (?#xxx) (?#yyy) {3}c'x aaac y $& aaac -(?<![cd])b dbcb n - - -(?<![cd])[ab] dbaacb y $& a -(?<!(c|d))b dbcb n - - -(?<!(c|d))[ab] dbaacb y $& a -(?<!cd)[ab] cdaccb y $& b -^(?:a?b?)*$ a-- n - - -((?s)^a(.))((?m)^b$) a\nb\nc\n y $1;$2;$3 a\n;\n;b -((?m)^b$) a\nb\nc\n y $1 b -(?m)^b a\nb\n y $& b -(?m)^(b) a\nb\n y $1 b -((?m)^b) a\nb\n y $1 b -\n((?m)^b) a\nb\n y $1 b -((?s).)c(?!.) a\nb\nc\n y $1 \n -((?s).)c(?!.) a\nb\nc\n y $1:$& \n:\nc -((?s)b.)c(?!.) a\nb\nc\n y $1 b\n -((?s)b.)c(?!.) a\nb\nc\n y $1:$& b\n:b\nc -^b a\nb\nc\n n - - -()^b a\nb\nc\n n - - -((?m)^b) a\nb\nc\n y $1 b -(?(1)a|b) a n - - -(?(1)b|a) a y $& a -(x)?(?(1)a|b) a n - - -(x)?(?(1)b|a) a y $& a -()?(?(1)b|a) a y $& a -()(?(1)b|a) a n - - -()?(?(1)a|b) a y $& a -^(\()?blah(?(1)(\)))$ (blah) y $2 ) -^(\()?blah(?(1)(\)))$ blah y ($2) () -^(\()?blah(?(1)(\)))$ blah) n - - -^(\()?blah(?(1)(\)))$ (blah n - - -^(\(+)?blah(?(1)(\)))$ (blah) y $2 ) -^(\(+)?blah(?(1)(\)))$ blah y ($2) () -^(\(+)?blah(?(1)(\)))$ blah) n - - -^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ -(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches -(?(?{0})a|b) a n - - -(?(?{0})b|a) a y $& a -(?(?{1})b|a) a n - - -(?(?{1})a|b) a y $& a -(?(?!a)a|b) a n - - -(?(?!a)b|a) a y $& a -(?(?=a)b|a) a n - - -(?(?=a)a|b) a y $& a -(?=(a+?))(\1ab) aaab y $2 aab -^(?=(a+?))\1ab aaab n - - -(\w+:)+ one: y $1 one: -$(?<=^(a)) a y $1 a -(?=(a+?))(\1ab) aaab y $2 aab -^(?=(a+?))\1ab aaab n - - -([\w:]+::)?(\w+)$ abcd: n - - -([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd -([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd -^[^bcd]*(c+) aexycd y $1 c -(a*)b+ caab y $1 aa -([\w:]+::)?(\w+)$ abcd: n - - -([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd -([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd -^[^bcd]*(c+) aexycd y $1 c -(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a}) yaaxxaaaacd y $b 3 -(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) yaaxxaaaacd y $b 4 -(>a+)ab aaab n - - -(?>a+)b aaab y - - -([[:]+) a:[b]: y $1 :[ -([[=]+) a=[b]= y $1 =[ -([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ -[a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE / -[a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ -[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 - POSIX class [:foo:] unknown before HERE mark in regex m/[[:foo:] << HERE ]/ -[[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/ -((?>a+)b) aaab y $1 aaab -(?>(a+))b aaab y $1 aaa -((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x -(?<=x+)y - c - Variable length lookbehind not implemented -a{37,17} - c - Can't do {n,m} with n > m -\Z a\nb\n y $-[0] 3 -\z a\nb\n y $-[0] 4 -$ a\nb\n y $-[0] 3 -\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 - - -a\z a\nb\n n - - -a$ a\nb\n n - - -a\Z b\na\n y $-[0] 2 -a\z b\na\n n - - -a$ b\na\n y $-[0] 2 -a\Z b\na y $-[0] 2 -a\z b\na y $-[0] 2 -a$ b\na y $-[0] 2 -'a\Z'm a\nb\n bn - - -'a\z'm a\nb\n n - - -'a$'m a\nb\n y $-[0] 0 -'a\Z'm b\na\n y $-[0] 2 -'a\z'm b\na\n n - - -'a$'m b\na\n y $-[0] 2 -'a\Z'm b\na y $-[0] 2 -'a\z'm b\na y $-[0] 2 -'a$'m b\na y $-[0] 2 -aa\Z aa\nb\n n - - -aa\z aa\nb\n n - - -aa$ aa\nb\n n - - -aa\Z b\naa\n y $-[0] 2 -aa\z b\naa\n n - - -aa$ b\naa\n y $-[0] 2 -aa\Z b\naa y $-[0] 2 -aa\z b\naa y $-[0] 2 -aa$ b\naa y $-[0] 2 -'aa\Z'm aa\nb\n bn - - -'aa\z'm aa\nb\n n - - -'aa$'m aa\nb\n y $-[0] 0 -'aa\Z'm b\naa\n y $-[0] 2 -'aa\z'm b\naa\n n - - -'aa$'m b\naa\n y $-[0] 2 -'aa\Z'm b\naa y $-[0] 2 -'aa\z'm b\naa y $-[0] 2 -'aa$'m b\naa y $-[0] 2 -aa\Z ac\nb\n n - - -aa\z ac\nb\n n - - -aa$ ac\nb\n n - - -aa\Z b\nac\n n - - -aa\z b\nac\n n - - -aa$ b\nac\n n - - -aa\Z b\nac n - - -aa\z b\nac n - - -aa$ b\nac n - - -'aa\Z'm ac\nb\n n - - -'aa\z'm ac\nb\n n - - -'aa$'m ac\nb\n n - - -'aa\Z'm b\nac\n n - - -'aa\z'm b\nac\n n - - -'aa$'m b\nac\n n - - -'aa\Z'm b\nac n - - -'aa\z'm b\nac n - - -'aa$'m b\nac n - - -aa\Z ca\nb\n n - - -aa\z ca\nb\n n - - -aa$ ca\nb\n n - - -aa\Z b\nca\n n - - -aa\z b\nca\n n - - -aa$ b\nca\n n - - -aa\Z b\nca n - - -aa\z b\nca n - - -aa$ b\nca n - - -'aa\Z'm ca\nb\n n - - -'aa\z'm ca\nb\n n - - -'aa$'m ca\nb\n n - - -'aa\Z'm b\nca\n n - - -'aa\z'm b\nca\n n - - -'aa$'m b\nca\n n - - -'aa\Z'm b\nca n - - -'aa\z'm b\nca n - - -'aa$'m b\nca n - - -ab\Z ab\nb\n n - - -ab\z ab\nb\n n - - -ab$ ab\nb\n n - - -ab\Z b\nab\n y $-[0] 2 -ab\z b\nab\n n - - -ab$ b\nab\n y $-[0] 2 -ab\Z b\nab y $-[0] 2 -ab\z b\nab y $-[0] 2 -ab$ b\nab y $-[0] 2 -'ab\Z'm ab\nb\n bn - - -'ab\z'm ab\nb\n n - - -'ab$'m ab\nb\n y $-[0] 0 -'ab\Z'm b\nab\n y $-[0] 2 -'ab\z'm b\nab\n n - - -'ab$'m b\nab\n y $-[0] 2 -'ab\Z'm b\nab y $-[0] 2 -'ab\z'm b\nab y $-[0] 2 -'ab$'m b\nab y $-[0] 2 -ab\Z ac\nb\n n - - -ab\z ac\nb\n n - - -ab$ ac\nb\n n - - -ab\Z b\nac\n n - - -ab\z b\nac\n n - - -ab$ b\nac\n n - - -ab\Z b\nac n - - -ab\z b\nac n - - -ab$ b\nac n - - -'ab\Z'm ac\nb\n n - - -'ab\z'm ac\nb\n n - - -'ab$'m ac\nb\n n - - -'ab\Z'm b\nac\n n - - -'ab\z'm b\nac\n n - - -'ab$'m b\nac\n n - - -'ab\Z'm b\nac n - - -'ab\z'm b\nac n - - -'ab$'m b\nac n - - -ab\Z ca\nb\n n - - -ab\z ca\nb\n n - - -ab$ ca\nb\n n - - -ab\Z b\nca\n n - - -ab\z b\nca\n n - - -ab$ b\nca\n n - - -ab\Z b\nca n - - -ab\z b\nca n - - -ab$ b\nca n - - -'ab\Z'm ca\nb\n n - - -'ab\z'm ca\nb\n n - - -'ab$'m ca\nb\n n - - -'ab\Z'm b\nca\n n - - -'ab\z'm b\nca\n n - - -'ab$'m b\nca\n n - - -'ab\Z'm b\nca n - - -'ab\z'm b\nca n - - -'ab$'m b\nca n - - -abb\Z abb\nb\n n - - -abb\z abb\nb\n n - - -abb$ abb\nb\n n - - -abb\Z b\nabb\n y $-[0] 2 -abb\z b\nabb\n n - - -abb$ b\nabb\n y $-[0] 2 -abb\Z b\nabb y $-[0] 2 -abb\z b\nabb y $-[0] 2 -abb$ b\nabb y $-[0] 2 -'abb\Z'm abb\nb\n bn - - -'abb\z'm abb\nb\n n - - -'abb$'m abb\nb\n y $-[0] 0 -'abb\Z'm b\nabb\n y $-[0] 2 -'abb\z'm b\nabb\n n - - -'abb$'m b\nabb\n y $-[0] 2 -'abb\Z'm b\nabb y $-[0] 2 -'abb\z'm b\nabb y $-[0] 2 -'abb$'m b\nabb y $-[0] 2 -abb\Z ac\nb\n n - - -abb\z ac\nb\n n - - -abb$ ac\nb\n n - - -abb\Z b\nac\n n - - -abb\z b\nac\n n - - -abb$ b\nac\n n - - -abb\Z b\nac n - - -abb\z b\nac n - - -abb$ b\nac n - - -'abb\Z'm ac\nb\n n - - -'abb\z'm ac\nb\n n - - -'abb$'m ac\nb\n n - - -'abb\Z'm b\nac\n n - - -'abb\z'm b\nac\n n - - -'abb$'m b\nac\n n - - -'abb\Z'm b\nac n - - -'abb\z'm b\nac n - - -'abb$'m b\nac n - - -abb\Z ca\nb\n n - - -abb\z ca\nb\n n - - -abb$ ca\nb\n n - - -abb\Z b\nca\n n - - -abb\z b\nca\n n - - -abb$ b\nca\n n - - -abb\Z b\nca n - - -abb\z b\nca n - - -abb$ b\nca n - - -'abb\Z'm ca\nb\n n - - -'abb\z'm ca\nb\n n - - -'abb$'m ca\nb\n n - - -'abb\Z'm b\nca\n n - - -'abb\z'm b\nca\n n - - -'abb$'m b\nca\n n - - -'abb\Z'm b\nca n - - -'abb\z'm b\nca n - - -'abb$'m b\nca n - - -(^|x)(c) ca y $2 c -a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - -a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2 -round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz -'((?x:.) )' x y $1- x - -'((?-x:.) )'x x y $1- x- -foo.bart foo.bart y - - -'^d[x][x][x]'m abcd\ndxxx y - - -.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -tt+$ xxxtt y - - -([a-\d]+) za-9z y $1 a-9 -([\d-z]+) a0-za y $1 0-z -([\d-\s]+) a0- z y $1 0- -([a-[:digit:]]+) za-9z y $1 a-9 -([[:digit:]-z]+) =0-z= y $1 0-z -([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z -\GX.*X aaaXbX n - - -(\d+\.\d+) 3.1415926 y $1 3.1415926 -(\ba.{0,10}br) have a web browser y $1 a web br -'\.c(pp|xx|c)?$'i Changes n - - -'\.c(pp|xx|c)?$'i IO.c y - - -'(\.c(pp|xx|c)?$)'i IO.c y $1 .c -^([a-z]:) C:/ n - - -'^\S\s+aa$'m \nx aa y - - -(^|a)b ab y - - -^([ab]*?)(b)?(c)$ abac y -$2- -- -(\w)?(abc)\1b abcab n - - -^(?:.,){2}c a,b,c y - - -^(.,){2}c a,b,c y $1 b, -^(?:[^,]*,){2}c a,b,c y - - -^([^,]*,){2}c a,b,c y $1 b, -^([^,]*,){3}d aaa,b,c,d y $1 c, -^([^,]*,){3,}d aaa,b,c,d y $1 c, -^([^,]*,){0,3}d aaa,b,c,d y $1 c, -^([^,]{1,3},){3}d aaa,b,c,d y $1 c, -^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, -^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, -^([^,]{1,},){3}d aaa,b,c,d y $1 c, -^([^,]{1,},){3,}d aaa,b,c,d y $1 c, -^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, -^([^,]{0,3},){3}d aaa,b,c,d y $1 c, -^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, -^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, -(?i) y - - -'(?!\A)x'm a\nxb\n y - - -^(a(b)?)+$ aba y -$1-$2- -a-- -^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- -'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - -^(a)?a$ a y -$1- -- -^(a)?(?(1)a|b)+$ a n - - -^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa -^(a\1?){4}$ aaaaaa y $1 aa -^(0+)?(?:x(1))? x1 y - - -^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - -^(b+?|a){1,2}c bbbac y $1 a -^(b+?|a){1,2}c bbbbac y $1 a -\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- -((?:aaaa|bbbb)cccc)? aaaacccc y - - -((?:aaaa|bbbb)cccc)? bbbbcccc y - - diff --git a/contrib/perl5/t/op/read.t b/contrib/perl5/t/op/read.t deleted file mode 100755 index 2746970..0000000 --- a/contrib/perl5/t/op/read.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -# $RCSfile: read.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:17 $ - -print "1..4\n"; - - -open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read"; -seek(FOO,4,0); -$got = read(FOO,$buf,4); - -print ($got == 4 ? "ok 1\n" : "not ok 1\n"); -print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n"); - -seek (FOO,0,2) || seek(FOO,20000,0); -$got = read(FOO,$buf,4); - -print ($got == 0 ? "ok 3\n" : "not ok 3\n"); -print ($buf eq "" ? "ok 4\n" : "not ok 4\n"); diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t deleted file mode 100755 index 00199b0..0000000 --- a/contrib/perl5/t/op/readdir.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -eval 'opendir(NOSUCH, "no/such/directory");'; -if ($@) { print "1..0\n"; exit; } - -print "1..3\n"; - -for $i (1..2000) { - local *OP; - opendir(OP, "op") or die "can't opendir: $!"; - # should auto-closedir() here -} - -if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } -@D = grep(/^[^\.].*\.t$/i, readdir(OP)); -closedir(OP); - -## -## This range will have to adjust as the number of tests expands, -## as it's counting the number of .t files in src/t -## -if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; } - -@R = sort @D; -@G = sort <op/*.t>; -if ($G[0] =~ m#.*\](\w+\.t)#i) { - # grep is to convert filespecs returned from glob under VMS to format - # identical to that returned by readdir - @G = grep(s#.*\](\w+\.t).*#op/$1#i,<op/*.t>); -} -while (@R && @G && "op/".$R[0] eq $G[0]) { - shift(@R); - shift(@G); -} -if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; } diff --git a/contrib/perl5/t/op/recurse.t b/contrib/perl5/t/op/recurse.t deleted file mode 100755 index dc823ed..0000000 --- a/contrib/perl5/t/op/recurse.t +++ /dev/null @@ -1,116 +0,0 @@ -#!./perl - -# -# test recursive functions. -# - -print "1..25\n"; - -sub gcd ($$) { - return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); - return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); - $_[0]; -} - -sub factorial ($) { - $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); -} - -sub fibonacci ($) { - $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); -} - -# Highly recursive, highly aggressive. -# Kids, don't try this at home. -# -# For example ackermann(4,1) will take quite a long time. -# It will simply eat away your memory. Trust me. - -sub ackermann ($$) { - return $_[1] + 1 if ($_[0] == 0); - return ackermann($_[0] - 1, 1) if ($_[1] == 0); - ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); -} - -# Highly recursive, highly boring. - -sub takeuchi ($$$) { - $_[1] < $_[0] ? - takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), - takeuchi($_[1] - 1, $_[2], $_[0]), - takeuchi($_[2] - 1, $_[0], $_[1])) - : $_[2]; -} - -print 'not ' unless (($d = gcd(1147, 1271)) == 31); -print "ok 1\n"; -print "# gcd(1147, 1271) = $d\n"; - -print 'not ' unless (($d = gcd(1908, 2016)) == 36); -print "ok 2\n"; -print "# gcd(1908, 2016) = $d\n"; - -print 'not ' unless (($f = factorial(10)) == 3628800); -print "ok 3\n"; -print "# factorial(10) = $f\n"; - -print 'not ' unless (($f = factorial(factorial(3))) == 720); -print "ok 4\n"; -print "# factorial(factorial(3)) = $f\n"; - -print 'not ' unless (($f = fibonacci(10)) == 89); -print "ok 5\n"; -print "# fibonacci(10) = $f\n"; - -print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711); -print "ok 6\n"; -print "# fibonacci(fibonacci(7)) = $f\n"; - -$i = 7; - -@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); - -for $x (0..3) { - for $y (0..3) { - $a = ackermann($x, $y); - print 'not ' unless ($a == shift(@ack)); - print "ok ", $i++, "\n"; - print "# ackermann($x, $y) = $a\n"; - } -} - -($x, $y, $z) = (18, 12, 6); - -print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); -print "ok ", $i++, "\n"; -print "# takeuchi($x, $y, $z) = $t\n"; - -{ - sub get_first1 { - get_list1(@_)->[0]; - } - - sub get_list1 { - return [24] unless $_[0]; - my $u = get_first1(0); - [$u]; - } - my $x = get_first1(1); - print "ok $x\n"; -} - -{ - sub get_first2 { - return get_list2(@_)->[0]; - } - - sub get_list2 { - return [25] unless $_[0]; - my $u = get_first2(0); - return [$u]; - } - my $x = get_first2(1); - print "ok $x\n"; -} - -$i = 26; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t deleted file mode 100755 index a2baab8..0000000 --- a/contrib/perl5/t/op/ref.t +++ /dev/null @@ -1,295 +0,0 @@ -#!./perl - -print "1..56\n"; - -# Test glob operations. - -$bar = "ok 1\n"; -$foo = "ok 2\n"; -{ - local(*foo) = *bar; - print $foo; -} -print $foo; - -$baz = "ok 3\n"; -$foo = "ok 4\n"; -{ - local(*foo) = 'baz'; - print $foo; -} -print $foo; - -$foo = "ok 6\n"; -{ - local(*foo); - print $foo; - $foo = "ok 5\n"; - print $foo; -} -print $foo; - -# Test fake references. - -$baz = "ok 7\n"; -$bar = 'baz'; -$foo = 'bar'; -print $$$foo; - -# Test real references. - -$FOO = \$BAR; -$BAR = \$BAZ; -$BAZ = "ok 8\n"; -print $$$FOO; - -# Test references to real arrays. - -@ary = (9,10,11,12); -$ref[0] = \@a; -$ref[1] = \@b; -$ref[2] = \@c; -$ref[3] = \@d; -for $i (3,1,2,0) { - push(@{$ref[$i]}, "ok $ary[$i]\n"); -} -print @a; -print ${$ref[1]}[0]; -print @{$ref[2]}[0]; -print @{'d'}; - -# Test references to references. - -$refref = \\$x; -$x = "ok 13\n"; -print $$$refref; - -# Test nested anonymous lists. - -$ref = [[],2,[3,4,5,]]; -print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n"; -print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n"; -print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; -print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; - -print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; -print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; - -# Test references to hashes of references. - -$refref = \%whatever; -$refref->{"key"} = $ref; -print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n"; - -# Test to see if anonymous subarrays spring into existence. - -$spring[5]->[0] = 123; -$spring[5]->[1] = 456; -push(@{$spring[5]}, 789); -print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n"; - -# Test to see if anonymous subhashes spring into existence. - -@{$spring2{"foo"}} = (1,2,3); -$spring2{"foo"}->[3] = 4; -print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n"; - -# Test references to subroutines. - -sub mysub { print "ok 23\n" } -$subref = \&mysub; -&$subref; - -$subrefref = \\&mysub2; -$$subrefref->("ok 24\n"); -sub mysub2 { print shift } - -# Test the ref operator. - -print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n"; -print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n"; -print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n"; - -# Test anonymous hash syntax. - -$anonhash = {}; -print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n"; -$anonhash2 = {FOO => BAR, ABC => XYZ,}; -print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n"; - -# Test bless operator. - -package MYHASH; - -$object = bless $main'anonhash2; -print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n"; -print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n"; - -$object2 = bless {}; -print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n"; - -# Test ordinary call on object method. - -&mymethod($object,33); - -sub mymethod { - local($THIS, @ARGS) = @_; - die 'Got a "' . ref($THIS). '" instead of a MYHASH' - unless ref $THIS eq MYHASH; - print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n"; -} - -# Test automatic destructor call. - -$string = "not ok 34\n"; -$object = "foo"; -$string = "ok 34\n"; -$main'anonhash2 = "foo"; -$string = ""; - -DESTROY { - return unless $string; - print $string; - - # Test that the object has not already been "cursed". - print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; -} - -# Now test inheritance of methods. - -package OBJ; - -@ISA = (BASEOBJ); - -$main'object = bless {FOO => foo, BAR => bar}; - -package main; - -# Test arrow-style method invocation. - -print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n"; - -# Test indirect-object-style method invocation. - -$foo = doit $object "FOO"; -print $foo eq foo ? "ok 37\n" : "not ok 37\n"; - -sub BASEOBJ'doit { - local $ref = shift; - die "Not an OBJ" unless ref $ref eq OBJ; - $ref->{shift()}; -} - -package UNIVERSAL; -@ISA = 'LASTCHANCE'; - -package LASTCHANCE; -sub foo { print $_[1] } - -package WHATEVER; -foo WHATEVER "ok 38\n"; - -# -# test the \(@foo) construct -# -package main; -@foo = (1,2,3); -@bar = \(@foo); -@baz = \(1,@foo,@bar); -print @bar == 3 ? "ok 39\n" : "not ok 39\n"; -print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n"; -print @baz == 3 ? "ok 41\n" : "not ok 41\n"; - -my(@fuu) = (1,2,3); -my(@baa) = \(@fuu); -my(@bzz) = \(1,@fuu,@baa); -print @baa == 3 ? "ok 42\n" : "not ok 42\n"; -print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; -print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; - -# test for proper destruction of lexical objects - -sub larry::DESTROY { print "# larry\nok 45\n"; } -sub curly::DESTROY { print "# curly\nok 46\n"; } -sub moe::DESTROY { print "# moe\nok 47\n"; } - -{ - my ($joe, @curly, %larry); - my $moe = bless \$joe, 'moe'; - my $curly = bless \@curly, 'curly'; - my $larry = bless \%larry, 'larry'; - print "# leaving block\n"; -} - -print "# left block\n"; - -# another glob test - -$foo = "not ok 48"; -{ local(*bar) = "foo" } -$bar = "ok 48"; -local(*bar) = *bar; -print "$bar\n"; - -$var = "ok 49"; -$_ = \$var; -print $$_,"\n"; - -# test if reblessing during destruction results in more destruction - -{ - package A; - sub new { bless {}, shift } - DESTROY { print "# destroying 'A'\nok 51\n" } - package _B; - sub new { bless {}, shift } - DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' } - package main; - my $b = _B->new; -} - -# test if $_[0] is properly protected in DESTROY() - -{ - my $i = 0; - local $SIG{'__DIE__'} = sub { - my $m = shift; - if ($i++ > 4) { - print "# infinite recursion, bailing\nnot ok 52\n"; - exit 1; - } - print "# $m"; - if ($m =~ /^Modification of a read-only/) { print "ok 52\n" } - }; - package C; - sub new { bless {}, shift } - DESTROY { $_[0] = 'foo' } - { - print "# should generate an error...\n"; - my $c = C->new; - } - 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 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 -} - -DESTROY { - print $_[0][0]; -} diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t deleted file mode 100755 index 4a4d42f..0000000 --- a/contrib/perl5/t/op/regexp.t +++ /dev/null @@ -1,112 +0,0 @@ -#!./perl - -# The tests are in a separate file 't/op/re_tests'. -# Each line in that file is a separate test. -# There are five columns, separated by tabs. -# -# Column 1 contains the pattern, optionally enclosed in C<''>. -# Modifiers can be put after the closing C<'>. -# -# Column 2 contains the string to be matched. -# -# Column 3 contains the expected result: -# 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>. -# -# Column 4 contains a string, usually C<$&>. -# -# Column 5 contains the expected result of double-quote -# interpolating that string after the match, or start of error message. -# -# Column 6, if present, contains a reason why the test is skipped. -# This is printed with "skipped", for harness to pick up. -# -# \n in the tests are interpolated, as are variables of the form ${\w+}. -# -# If you want to add a regular expression test that can't be expressed -# in this format, don't add it here: put it in op/pat.t instead. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -$iters = shift || 1; # Poor man performance suite, 10000 is OK. - -open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || - die "Can't open re_tests"; - -while (<TESTS>) { } -$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: -while (<TESTS>) { - chomp; - s/\\n/\n/g; - ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); - $input = join(':',$pat,$subject,$result,$repl,$expect); - 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 =~ /\$[&\`\']/; - $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, $reason = 'utf8' - if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/; - $result =~ s/B//i unless $skip; - for $study ('', 'study \$subject') { - $c = $iters; - eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";"; - chomp( $err = $@ ); - if ($result eq 'c') { - 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", length($reason) ? " $reason" : '', "\n"; - next TEST; - } - elsif ($@) { - print "not ok $. $input => error `$err'\n"; next TEST; - } - elsif ($result eq 'n') { - if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST } - } - else { - if (!$match || $got ne $expect) { - print "not ok $. ($study) $input => `$got', match=$match\n"; - next TEST; - } - } - } - print "ok $.\n"; -} - -close(TESTS); - -sub infty_subst # Special-case substitution -{ # of $reg_infty and friends - my $tp = shift; - $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o; - $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o; - $$tp =~ s/,\$reg_infty}/,$reg_infty}/o; -} diff --git a/contrib/perl5/t/op/regexp_noamp.t b/contrib/perl5/t/op/regexp_noamp.t deleted file mode 100755 index 03c19e9..0000000 --- a/contrib/perl5/t/op/regexp_noamp.t +++ /dev/null @@ -1,10 +0,0 @@ -#!./perl - -$skip_amp = 1; -for $file ('op/regexp.t', 't/op/regexp.t') { - if (-r $file) { - do $file; - exit; - } -} -die "Cannot find op/regexp.t or t/op/regexp.t\n"; diff --git a/contrib/perl5/t/op/regmesg.t b/contrib/perl5/t/op/regmesg.t deleted file mode 100755 index 01fa675..0000000 --- a/contrib/perl5/t/op/regmesg.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my $debug = 1; - -## -## If the markers used are changed (search for "MARKER1" in regcomp.c), -## update only these two variables, and leave the {#} in the @death/@warning -## arrays below. The {#} is a meta-marker -- it marks where the marker should -## go. - -my $marker1 = "HERE"; -my $marker2 = " << HERE "; - -## -## Key-value pairs of code/error of code that should have fatal errors. -## - -eval 'use Config'; # assume defaults if fail -our %Config; -my $inf_m1 = ($Config{reg_infty} || 32767) - 1; -my $inf_p1 = $inf_m1 + 2; -my @death = -( - '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=foo=]{#}]/', - - '/(?<= .*)/' => 'Variable length lookbehind not implemented before {#} mark in regex m/(?<= .*){#}/', - - '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented before {#} mark in regex m/(?<= x{1000}){#}/', - - '/(?@)/' => 'Sequence (?@...) not implemented before {#} mark in regex m/(?@{#})/', - - '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced before {#} mark in regex m/(?{{#} 1/', - - '/(?(1x))/' => 'Switch condition not recognized before {#} mark in regex m/(?(1x{#}))/', - - '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches before {#} mark in regex m/(?(1)x|y|{#}z)/', - - '/(?(x)y|x)/' => 'Unknown switch condition (?(x) before {#} mark in regex m/(?({#}x)y|x)/', - - '/(?/' => 'Sequence (? incomplete before {#} mark in regex m/(?{#}/', - - '/(?;x/' => 'Sequence (?;...) not recognized before {#} mark in regex m/(?;{#}x/', - '/(?<;x/' => 'Sequence (?<;...) not recognized before {#} mark in regex m/(?<;{#}x/', - - '/((x)/' => 'Unmatched ( before {#} mark in regex m/({#}(x)/', - - "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 before {#} mark in regex m/x{{#}$inf_p1}/", - - '/x{3,1}/' => 'Can\'t do {n,m} with n > m before {#} mark in regex m/x{3,1}{#}/', - - '/x**/' => 'Nested quantifiers before {#} mark in regex m/x**{#}/', - - '/x[/' => 'Unmatched [ before {#} mark in regex m/x[{#}/', - - '/*/', => 'Quantifier follows nothing before {#} mark in regex m/*{#}/', - - '/\p{x/' => 'Missing right brace on \p{} before {#} mark in regex m/\p{{#}x/', - - 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} before {#} mark in regex m/[\p{{#}x]/', - - '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/', - - 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', - - '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/', - - 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/', - - '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/', - - '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/', - - '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions before {#} mark in regex m/[[.barf.]{#}]/', - - '/[z-a]/' => 'Invalid [] range "z-a" before {#} mark in regex m/[z-a{#}]/', -); - -## -## Key-value pairs of code/error of code that should have non-fatal warnings. -## -@warning = ( - "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) before {#} mark in regex m/(?p{#}{ 'a' })/", - - 'm/\b*/' => '\b* matches null string many times before {#} mark in regex m/\b*{#}/', - - 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes before {#} mark in regex m/[:blank:]{#}/', - - "m'[\\y]'" => 'Unrecognized escape \y in character class passed through before {#} mark in regex m/[\y{#}]/', - - 'm/[a-\d]/' => 'False [] range "a-\d" before {#} mark in regex m/[a-\d{#}]/', - 'm/[\w-x]/' => 'False [] range "\w-" before {#} mark in regex m/[\w-{#}x]/', - "m'\\y'" => 'Unrecognized escape \y passed through before {#} mark in regex m/\y{#}/', -); - -my $total = (@death + @warning)/2; - -# utf8 is a noop on EBCDIC platforms, it is not fatal -my $Is_EBCDIC = (ord('A') == 193); -if ($Is_EBCDIC) { - my @utf8_death = grep(/utf8/, @death); - $total = $total - scalar(@utf8_death); -} - -print "1..$total\n"; - -my $count = 0; - -while (@death) -{ - my $regex = shift @death; - my $result = shift @death; - # skip the utf8 test on EBCDIC since they do not die - next if ($Is_EBCDIC && $regex =~ /utf8/); - $count++; - - $_ = "x"; - eval $regex; - if (not $@) { - print "# oops, $regex didn't die\nnot ok $count\n"; - next; - } - chomp $@; - $result =~ s/{\#}/$marker1/; - $result =~ s/{\#}/$marker2/; - if ($@ !~ /^\Q$result/) { - print "# For $regex, expected:\n# $result\n# Got:\n# $@\n#\nnot "; - } - print "ok $count\n"; -} - - -our $warning; -$SIG{__WARN__} = sub { $warning = shift }; - -while (@warning) -{ - $count++; - my $regex = shift @warning; - my $result = shift @warning; - - undef $warning; - $_ = "x"; - eval $regex; - - if ($@) - { - print "# oops, $regex died with:\n#\t$@#\nnot ok $count\n"; - next; - } - - if (not $warning) - { - print "# oops, $regex didn't generate a warning\nnot ok $count\n"; - next; - } - $result =~ s/{\#}/$marker1/; - $result =~ s/{\#}/$marker2/; - if ($warning !~ /^\Q$result/) - { - print <<"EOM"; -# For $regex, expected: -# $result -# Got: -# $warning -# -not ok $count -EOM - next; - } - print "ok $count\n"; -} - - - diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t deleted file mode 100755 index c030ba9..0000000 --- a/contrib/perl5/t/op/repeat.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl - -# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ - -print "1..20\n"; - -# compile time - -if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";} -if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";} -if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";} - -if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";} - -# run time - -$a = '-'; -if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";} -if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";} -if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";} - -$a = 'ab'; -if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";} - -$a = 'xyz'; -$a x= 2; -if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";} -$a x= 1; -if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";} -$a x= 0; -if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";} - -@x = (1,2,3); - -print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n"; -print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n"; -print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n"; -print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n"; -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/contrib/perl5/t/op/reverse.t b/contrib/perl5/t/op/reverse.t deleted file mode 100755 index bb7b9b7..0000000 --- a/contrib/perl5/t/op/reverse.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..4\n"; - -print "not " unless reverse("abc") eq "cba"; -print "ok 1\n"; - -$_ = "foobar"; -print "not " unless reverse() eq "raboof"; -print "ok 2\n"; - -{ - my @a = ("foo", "bar"); - my @b = reverse @a; - - print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0]; - print "ok 3\n"; -} - -{ - # Unicode. - - my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; - my $b = scalar reverse($a); - my $c = scalar reverse($b); - print "not " unless $a eq $c; - print "ok 4\n"; -} diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t deleted file mode 100755 index b6c128b..0000000 --- a/contrib/perl5/t/op/runlevel.t +++ /dev/null @@ -1,366 +0,0 @@ -#!./perl - -## -## Many of these tests are originally from Michael Schroeder -## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> -## - -chdir 't' if -d 't'; -@INC = '../lib'; -$Is_VMS = $^O eq 'VMS'; -$Is_MSWin32 = $^O eq 'MSWin32'; -$ENV{PERL5LIB} = "../lib" unless $Is_VMS; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "runltmp000"; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } - -for (@prgs){ - my $switch = ""; - if (s/^\s*(-\w+)//){ - $switch = $1; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, ">$tmpfile"; - print TEST "$prog\n"; - close TEST; - my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $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/runltmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $expected =~ s/\n+$//; - if ($results ne $expected) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ -@a = (1, 2, 3); -{ - @a = sort { last ; } @a; -} -EXPECT -Can't "last" outside a loop block at - line 3. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - eval 'die("test")'; - print "still in fetch\n"; - return ">$@<"; -} -package main; - -tie $bar, TEST; -print "- $bar\n"; -EXPECT -still in fetch -- >test at (eval 1) line 1. -< -######## -package TEST; - -sub TIESCALAR { - my $foo; - eval('die("foo\n")'); - print "after eval\n"; - return bless \$foo; -} -sub FETCH { - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -print "OK\n"; -EXPECT -after eval -- ZZZ -OK -######## -package TEST; - -sub TIEHANDLE { - my $foo; - return bless \$foo; -} -sub PRINT { -print STDERR "PRINT CALLED\n"; -(split(/./, 'x'x10000))[0]; -eval('die("test\n")'); -} - -package main; - -open FH, ">&STDOUT"; -tie *FH, TEST; -print FH "OK\n"; -print STDERR "DONE\n"; -EXPECT -PRINT CALLED -DONE -######## -sub warnhook { - print "WARNHOOK\n"; - eval('die("foooo\n")'); -} -$SIG{'__WARN__'} = 'warnhook'; -warn("dfsds\n"); -print "END\n"; -EXPECT -WARNHOOK -END -######## -package TEST; - -use overload - "\"\"" => \&str -; - -sub str { - eval('die("test\n")'); - return "STR"; -} - -package main; - -$bar = bless {}, TEST; -print "$bar\n"; -print "OK\n"; -EXPECT -STR -OK -######## -sub foo { - $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -sub foo { - goto bar if $a == 0 || $b == 0; - $a <=> $b; -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -exit; -bar: -print "bar reached\n"; -EXPECT -Can't "goto" out of a pseudo block at - line 2. -######## -sub sortfn { - (split(/./, 'x'x10000))[0]; - my (@y) = ( 4, 6, 5); - @y = sort { $a <=> $b } @y; - print "sortfn ".join(', ', @y)."\n"; - return $_[0] <=> $_[1]; -} -@x = ( 3, 2, 1 ); -@x = sort { &sortfn($a, $b) } @x; -print "---- ".join(', ', @x)."\n"; -EXPECT -sortfn 4, 5, 6 -sortfn 4, 5, 6 -sortfn 4, 5, 6 ----- 1, 2, 3 -######## -@a = (3, 2, 1); -@a = sort { eval('die("no way")') , $a <=> $b} @a; -print join(", ", @a)."\n"; -EXPECT -1, 2, 3 -######## -@a = (1, 2, 3); -foo: -{ - @a = sort { last foo; } @a; -} -EXPECT -Label not found for "last foo" at - line 2. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - next; - return "ZZZ"; -} -sub STORE { -} - -package main; - -tie $bar, TEST; -{ - print "- $bar\n"; -} -print "OK\n"; -EXPECT -Can't "next" outside a loop block at - line 8. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - goto bbb; - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -exit; -bbb: -print "bbb\n"; -EXPECT -Can't find label bbb at - line 8. -######## -sub foo { - $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -package TEST; -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - return "fetch"; -} -sub STORE { -(split(/./, 'x'x10000))[0]; -} -package main; -tie $bar, TEST; -$bar = "x"; -######## -package TEST; -sub TIESCALAR { - my $foo; - next; - return bless \$foo; -} -package main; -{ -tie $bar, TEST; -} -EXPECT -Can't "next" outside a loop block at - line 4. -######## -@a = (1, 2, 3); -foo: -{ - @a = sort { exit(0) } @a; -} -END { print "foobar\n" } -EXPECT -foobar -######## -$SIG{__DIE__} = sub { - print "In DIE\n"; - $i = 0; - while (($p,$f,$l,$s) = caller(++$i)) { - print "$p|$f|$l|$s\n"; - } -}; -eval { die }; -&{sub { eval 'die' }}(); -sub foo { eval { die } } foo(); -EXPECT -In DIE -main|-|8|(eval) -In DIE -main|-|9|(eval) -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 -######## -package TH; -sub TIEHASH { bless {}, TH } -sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } -tie %h, TH; -eval { $h{A} = 1; print "never\n"; }; -print $@; -eval { $h{B} = 2; }; -print $@; -EXPECT -A 1 -bar -B 2 -bar -######## -sub n { 0 } -sub f { my $x = shift; d(); } -f(n()); -f(); - -sub d { - my $i = 0; my @a; - while (do { { package DB; @a = caller($i++) } } ) { - @a = @DB::args; - for (@a) { print "$_\n"; $_ = '' } - } -} -EXPECT -0 diff --git a/contrib/perl5/t/op/sleep.t b/contrib/perl5/t/op/sleep.t deleted file mode 100755 index 5f6c4c0..0000000 --- a/contrib/perl5/t/op/sleep.t +++ /dev/null @@ -1,8 +0,0 @@ -#!./perl - -# $RCSfile: sleep.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:23 $ - -print "1..1\n"; - -$x = sleep 3; -if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";} diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t deleted file mode 100755 index 29aff1d..0000000 --- a/contrib/perl5/t/op/sort.t +++ /dev/null @@ -1,317 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -use warnings; -print "1..57\n"; - -# these shouldn't hang -{ - no warnings; - sort { for ($_ = 0;; $_++) {} } @a; - sort { while(1) {} } @a; - sort { while(1) { last; } } @a; - sort { while(0) { last; } } @a; -} - -sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } -sub Backwards_stacked($$) { my($a,$b) = @_; $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); -$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)); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 2: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); - -$x = join('', sort( Backwards_stacked @harry)); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); - -$x = join('', sort @george, 'to', @harry); -$expected = $upperfirst ? - 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : - 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 4: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 4\n":"not ok 4\n"); - -@a = (); -@b = reverse @a; -print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); - -@a = (1); -@b = reverse @a; -print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); - -@a = (1,2); -@b = reverse @a; -print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); - -@a = (1,2,3); -@b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); - -@a = (1,2,3,4); -@b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); - -@a = (10,2,3,4); -@b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); - -$sub = 'Backwards'; -$x = join('', sort $sub @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 11: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); - -$sub = 'Backwards_stacked'; -$x = join('', sort $sub @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 12: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); - -# literals, combinations - -@b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); -print "# x = '@b'\n"; - -@b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); -print "# x = '@b'\n"; - -@b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); -print "# x = '@b'\n"; - -@b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); -print "# x = '@b'\n"; - -# redefining sort sub inside the sort sub should fail -sub twoface { *twoface = sub { $a <=> $b }; &twoface } -eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); - -# redefining sort subs outside the sort should not fail -eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; -print $@ ? "not ok 18\n" : "ok 18\n"; - -eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); - -{ - no warnings 'redefine'; - *twoface = sub { *twoface = *Backwards; $a <=> $b }; -} -eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); - -{ - no warnings 'redefine'; - *twoface = sub { - eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); - $a <=> $b; - }; -} -eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 21\n"; - -eval <<'CODE'; - my @result = sort main'Backwards 'one', 'two'; -CODE -print $@ ? "not ok 22\n# $@" : "ok 22\n"; - -eval <<'CODE'; - # "sort 'one', 'two'" should not try to parse "'one" as a sort sub - my @result = sort 'one', 'two'; -CODE -print $@ ? "not ok 23\n# $@" : "ok 23\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 24\n" : "not ok 24 |@b|\n"); - @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); - @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); - @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); -} - -{ - my $sortsub = \&Backwards_stacked; - my $sortglob = *Backwards_stacked; - my $sortglobr = \*Backwards_stacked; - my $sortname = 'Backwards_stacked'; - @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); - @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); - @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); - @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); -} - -{ - local $sortsub = \&Backwards; - local $sortglob = *Backwards; - local $sortglobr = \*Backwards; - local $sortname = 'Backwards'; - @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); - @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); - @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); - @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); -} - -{ - local $sortsub = \&Backwards_stacked; - local $sortglob = *Backwards_stacked; - local $sortglobr = \*Backwards_stacked; - local $sortname = 'Backwards_stacked'; - @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); - @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); - @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); - @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); -} - -## exercise sort builtins... ($a <=> $b already tested) -@a = ( 5, 19, 1996, 255, 90 ); -@b = sort { - my $dummy; # force blockness - return $b <=> $a -} @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); -print "# x = '@b'\n"; -$x = join('', sort { $a cmp $b } @harry); -$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); -print "# x = '$x'; expected = '$expected'\n"; -$x = join('', sort { $b cmp $a } @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); -print "# x = '$x'; expected = '$expected'\n"; -{ - use integer; - @b = sort { $a <=> $b } @a; - print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); - print "# x = '@b'\n"; - @b = sort { $b <=> $a } @a; - print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); - print "# x = '@b'\n"; - $x = join('', sort { $a cmp $b } @harry); - $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); - print "# x = '$x'; expected = '$expected'\n"; - $x = join('', sort { $b cmp $a } @harry); - $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); - print "# x = '$x'; expected = '$expected'\n"; -} - -# test that an optimized-away comparison block doesn't take any other -# arguments away with it -$x = join('', sort { $a <=> $b } 3, 1, 2); -print $x eq "123" ? "ok 47\n" : "not ok 47\n"; - -# test sorting in non-main package -package Foo; -@a = ( 5, 19, 1996, 255, 90 ); -@b = sort { $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); -print "# x = '@b'\n"; - -@b = sort main::Backwards_stacked @a; -print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); -print "# x = '@b'\n"; - -# check if context for sort arguments is handled right - -$test = 49; -sub test_if_list { - my $gimme = wantarray; - print "not " unless $gimme; - ++$test; - print "ok $test\n"; -} -my $m = sub { $a <=> $b }; - -sub cxt_one { sort $m test_if_list() } -cxt_one(); -sub cxt_two { sort { $a <=> $b } test_if_list() } -cxt_two(); -sub cxt_three { sort &test_if_list() } -cxt_three(); - -sub test_if_scalar { - my $gimme = wantarray; - print "not " if $gimme or !defined($gimme); - ++$test; - print "ok $test\n"; -} - -$m = \&test_if_scalar; -sub cxt_four { sort $m 1,2 } -@x = cxt_four(); -sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } -@x = cxt_five(); -sub cxt_six { sort test_if_scalar 1,2 } -@x = cxt_six(); - -# test against a reentrancy bug -{ - package Bar; - sub compare { $a cmp $b } - sub reenter { my @force = sort compare qw/a b/ } -} -{ - my($def, $init) = (0, 0); - @b = sort { - $def = 1 if defined $Bar::a; - Bar::reenter() unless $init++; - $a <=> $b - } qw/4 3 1 2/; - print ("@b" eq '1 2 3 4' ? "ok 56\n" : "not ok 56\n"); - print "# x = '@b'\n"; - print !$def ? "ok 57\n" : "not ok 57\n"; -} diff --git a/contrib/perl5/t/op/splice.t b/contrib/perl5/t/op/splice.t deleted file mode 100755 index 06e3509..0000000 --- a/contrib/perl5/t/op/splice.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -print "1..9\n"; - -@a = (1..10); - -sub j { join(":",@_) } - -print "not " unless j(splice(@a,@a,0,11,12)) eq "" && j(@a) eq j(1..12); -print "ok 1\n"; - -print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11); -print "ok 2\n"; - -print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11); -print "ok 3\n"; - -print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11); -print "ok 4\n"; - -print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11); -print "ok 5\n"; - -print "not " unless j(splice(@a, 20, 0, 12, 13)) eq "" && j(@a) eq j(0..13); -print "ok 6\n"; - -print "not " unless j(splice(@a, -@a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3); -print "ok 7\n"; - -print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3); -print "ok 8\n"; - -print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3); -print "ok 9\n"; diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t deleted file mode 100755 index 9a6586d..0000000 --- a/contrib/perl5/t/op/split.t +++ /dev/null @@ -1,129 +0,0 @@ -#!./perl - -print "1..29\n"; - -$FS = ':'; - -$_ = 'a:b:c'; - -($a,$b,$c) = split($FS,$_); - -if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";} - -@ary = split(/:b:/); -if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = "abc\n"; -@xyz = (@ary = split(//)); -if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";} - -$_ = "a:b:c::::"; -@ary = split(/:/); -if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";} - -$_ = join(':',split(' '," a b\tc \t d ")); -if ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";} - -$_ = join(':',split(/ */,"foo bar bie\tdoll")); -if ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l") - {print "ok 6\n";} else {print "not ok 6\n";} - -$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); -if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";} - -# Can we say how many fields to split to? -$_ = join(':', split(' ','1 2 3 4 5 6', 3)); -print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n"; - -# Can we do it as a variable? -$x = 4; -$_ = join(':', split(' ','1 2 3 4 5 6', $x)); -print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n"; - -# Does the 999 suppress null field chopping? -$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); -print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; - -# Does assignment to a list imply split to one more field than that? -if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` } -elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` } -else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } -print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n"; - -# Can we say how many fields to split to when assigning to a list? -($a,$b) = split(' ','1 2 3 4 5 6', 2); -$_ = join(':',$a,$b); -print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n"; - -# do subpatterns generate additional fields (without trailing nulls)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,"); -print $_ eq "1|-|10||20" ? "ok 13\n" : "not ok 13\n"; - -# do subpatterns generate additional fields (with a limit)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); -print $_ eq "1|-|10||20||||||" ? "ok 14\n" : "not ok 14\n"; - -# is the 'two undefs' bug fixed? -(undef, $a, undef, $b) = qw(1 2 3 4); -print "$a|$b" eq "2|4" ? "ok 15\n" : "not ok 15\n"; - -# .. even for locals? -{ - local(undef, $a, undef, $b) = qw(1 2 3 4); - print "$a|$b" eq "2|4" ? "ok 16\n" : "not ok 16\n"; -} - -# check splitting of null string -$_ = join('|', split(/x/, '',-1), 'Z'); -print $_ eq "Z" ? "ok 17\n" : "#$_\nnot ok 17\n"; - -$_ = join('|', split(/x/, '', 1), 'Z'); -print $_ eq "Z" ? "ok 18\n" : "#$_\nnot ok 18\n"; - -$_ = join('|', split(/(p+)/,'',-1), 'Z'); -print $_ eq "Z" ? "ok 19\n" : "#$_\nnot ok 19\n"; - -$_ = join('|', split(/.?/, '',-1), 'Z'); -print $_ eq "Z" ? "ok 20\n" : "#$_\nnot ok 20\n"; - - -# Are /^/m patterns scanned? -$_ = join '|', split(/^a/m, "a b a\na d a", 20); -print $_ eq "| b a\n| d a" ? "ok 21\n" : "not ok 21\n# `$_'\n"; - -# Are /$/m patterns scanned? -$_ = join '|', split(/a$/m, "a b a\na d a", 20); -print $_ eq "a b |\na d |" ? "ok 22\n" : "not ok 22\n# `$_'\n"; - -# Are /^/m patterns scanned? -$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); -print $_ eq "| b aa\n| d aa" ? "ok 23\n" : "not ok 23\n# `$_'\n"; - -# Are /$/m patterns scanned? -$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); -print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; - -# Greedyness: -$_ = "a : b :c: d"; -@ary = split(/\s*:\s*/); -if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} - -# use of match result as pattern (!) -'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; -print "ok 26\n"; - -# /^/ treated as /^/m -$_ = join ':', split /^/, "ab\ncd\nef\n"; -print "not " if $_ ne "ab\n:cd\n:ef\n"; -print "ok 27\n"; - -# see if @a = @b = split(...) optimization works -@list1 = @list2 = split ('p',"a p b c p"); -print "not " if @list1 != @list2 or "@list1" ne "@list2" - or @list1 != 2 or "@list1" ne "a b c "; -print "ok 28\n"; - -# zero-width assertion -$_ = join ':', split /(?=\w)/, "rm b"; -print "not" if $_ ne "r:m :b"; -print "ok 29\n"; diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t deleted file mode 100755 index f4af3cd..0000000 --- a/contrib/perl5/t/op/sprintf.t +++ /dev/null @@ -1,310 +0,0 @@ -#!./perl - -# Tests sprintf, excluding handling of 64-bit integers or long -# doubles (if supported), of machine-specific short and long -# integers, machine-specific floating point exceptions (infinity, -# not-a-number ...), of the effects of locale, and of features -# specific to multi-byte characters (under use utf8 and such). - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -use warnings; - -while (<DATA>) { - s/^\s*>//; s/<\s*$//; - push @tests, [split(/<\s*>/, $_, 4)]; -} - -print '1..', scalar @tests, "\n"; - -$SIG{__WARN__} = sub { - if ($_[0] =~ /^Invalid conversion/) { - $w = ' INVALID' - } else { - warn @_; - } -}; - -for ($i = 1; @tests; $i++) { - ($template, $data, $result, $comment) = @{shift @tests}; - $evalData = eval $data; - $w = undef; - $x = sprintf(">$template<", - defined @$evalData ? @$evalData : $evalData); - substr($x, -1, 0) = $w if $w; - # $x may have 3 exponent digits, not 2 - my $y = $x; - if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { - # if result is left-adjusted, append extra space - if ($template =~ /%\+?\-/ and $result =~ / $/) { - $y =~ s/<$/ </; - } - # if result is zero-filled, add extra zero - elsif ($template =~ /%\+?0/ and $result =~ /^0/) { - $y =~ s/^>0/>00/; - } - # if result is right-adjusted, prepend extra space - elsif ($result =~ /^ /) { - $y =~ s/^>/> /; - } - } - - if ($x eq ">$result<") { - print "ok $i\n"; - } - elsif ($y eq ">$result<") # Some C libraries always give - { # three-digit exponent - print("ok $i # >$result< $x three-digit exponent accepted\n"); - } - elsif ($result =~ /[-+]\d{3}$/ && - # Suppress tests with modulo of exponent >= 100 on platforms - # which can't handle such magnitudes (or where we can't tell). - ((!eval {require POSIX}) || # Costly: only do this if we must! - (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) - { - print("ok $i # >$template< >$data< >$result<", - " Suppressed: exponent out of range?\n") - } - else { - $y = ($x eq $y ? "" : " => $y"); - print("not ok $i >$template< >$data< >$result< $x$y", - $comment ? " # $comment\n" : "\n"); - } -} - -# In each of the the following lines, there are three required fields: -# printf template, data to be formatted (as a Perl expression), and -# expected result of formatting. An optional fourth field can contain -# a comment. Each field is delimited by a starting '>' and a -# finishing '<'; any whitespace outside these start and end marks is -# not part of the field. If formatting requires more than one data -# item (for example, if variable field widths are used), the Perl data -# expression should return a reference to an array having the requisite -# number of elements. Even so, subterfuge is sometimes required: see -# tests for %n and %p. -# -# The following tests are not currently run, for the reasons stated: - -=pod - -=begin problematic - ->%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX< ->%.0f< >1.5< >2< >Standard vague: no rounding rules< ->%.0f< >2.5< >2< >Standard vague: no rounding rules< - -=end problematic - -=cut - -# template data result -__END__ ->%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< ->%6 .6s< >''< >%6 .6s INVALID< ->%6.6 s< >''< >%6.6 s INVALID< ->%A< >''< >%A INVALID< ->%B< >''< >%B INVALID< ->%C< >''< >%C INVALID< ->%D< >0x7fffffff< >2147483647< >Synonym for %ld< ->%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< ->%F< >123456.789< >123456.789000< >Synonym for %f< ->%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< ->%G< >1234567e96< >1.23457E+102< ->%G< >.1234567e-101< >1.23457E-102< ->%G< >12345.6789< >12345.7< ->%H< >''< >%H INVALID< ->%I< >''< >%I INVALID< ->%J< >''< >%J INVALID< ->%K< >''< >%K INVALID< ->%L< >''< >%L INVALID< ->%M< >''< >%M INVALID< ->%N< >''< >%N INVALID< ->%O< >2**32-1< >37777777777< >Synonum for %lo< ->%P< >''< >%P INVALID< ->%Q< >''< >%Q INVALID< ->%R< >''< >%R INVALID< ->%S< >''< >%S INVALID< ->%T< >''< >%T INVALID< ->%U< >2**32-1< >4294967295< >Synonum for %lu< ->%V< >''< >%V INVALID< ->%W< >''< >%W INVALID< ->%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< ->%#X< >2**32-1< >0XFFFFFFFF< ->%Y< >''< >%Y INVALID< ->%Z< >''< >%Z INVALID< ->%a< >''< >%a INVALID< ->%b< >2**32-1< >11111111111111111111111111111111< ->%+b< >2**32-1< >11111111111111111111111111111111< ->%#b< >2**32-1< >0b11111111111111111111111111111111< ->%34b< >2**32-1< > 11111111111111111111111111111111< ->%034b< >2**32-1< >0011111111111111111111111111111111< ->%-34b< >2**32-1< >11111111111111111111111111111111 < ->%-034b< >2**32-1< >11111111111111111111111111111111 < ->%c< >ord('A')< >A< ->%10c< >ord('A')< > A< ->%#10c< >ord('A')< > A< ># modifier: no effect< ->%010c< >ord('A')< >000000000A< ->%10lc< >ord('A')< > A< >l modifier: no effect< ->%10hc< >ord('A')< > A< >h modifier: no effect< ->%10.5c< >ord('A')< > A< >precision: no effect< ->%-10c< >ord('A')< >A < ->%d< >123456.789< >123456< ->%d< >-123456.789< >-123456< ->%d< >0< >0< ->%+d< >0< >+0< ->%0d< >0< >0< ->%.0d< >0< >< ->%+.0d< >0< >+< ->%.0d< >1< >1< ->%d< >1< >1< ->%+d< >1< >+1< ->%#3.2d< >1< > 01< ># modifier: no effect< ->%3.2d< >1< > 01< ->%03.2d< >1< >001< ->%-3.2d< >1< >01 < ->%-03.2d< >1< >01 < >zero pad + left just.: no effect< ->%d< >-1< >-1< ->%+d< >-1< >-1< ->%hd< >1< >1< >More extensive testing of< ->%ld< >1< >1< >length modifiers would be< ->%Vd< >1< >1< >platform-specific< ->%vd< >chr(1)< >1< ->%+vd< >chr(1)< >+1< ->%#vd< >chr(1)< >1< ->%vd< >"\01\02\03"< >1.2.3< ->%v.3d< >"\01\02\03"< >001.002.003< ->%v03d< >"\01\02\03"< >001.002.003< ->%v-3d< >"\01\02\03"< >1 .2 .3 < ->%v+-3d< >"\01\02\03"< >+1 .2 .3 < ->%v4.3d< >"\01\02\03"< > 001. 002. 003< ->%v04.3d< >"\01\02\03"< >0001.0002.0003< ->%*v02d< >['-', "\0\7\14"]< >00-07-12< ->%v.*d< >[3, "\01\02\03"]< >001.002.003< ->%v0*d< >[3, "\01\02\03"]< >001.002.003< ->%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < ->%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < ->%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< ->%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< ->%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11< ->%e< >1234.875< >1.234875e+03< ->%e< >0.000012345< >1.234500e-05< ->%e< >1234567E96< >1.234567e+102< ->%e< >0< >0.000000e+00< ->%e< >.1234567E-101< >1.234567e-102< ->%+e< >1234.875< >+1.234875e+03< ->%#e< >1234.875< >1.234875e+03< ->%e< >-1234.875< >-1.234875e+03< ->%+e< >-1234.875< >-1.234875e+03< ->%#e< >-1234.875< >-1.234875e+03< ->%.0e< >1234.875< >1e+03< ->%#.0e< >1234.875< >1.e+03< ->%.*e< >[0, 1234.875]< >1e+03< ->%.1e< >1234.875< >1.2e+03< ->%-12.4e< >1234.875< >1.2349e+03 < ->%12.4e< >1234.875< > 1.2349e+03< ->%+-12.4e< >1234.875< >+1.2349e+03 < ->%+12.4e< >1234.875< > +1.2349e+03< ->%+-12.4e< >-1234.875< >-1.2349e+03 < ->%+12.4e< >-1234.875< > -1.2349e+03< ->%f< >1234.875< >1234.875000< ->%+f< >1234.875< >+1234.875000< ->%#f< >1234.875< >1234.875000< ->%f< >-1234.875< >-1234.875000< ->%+f< >-1234.875< >-1234.875000< ->%#f< >-1234.875< >-1234.875000< ->%6f< >1234.875< >1234.875000< ->%*f< >[6, 1234.875]< >1234.875000< ->%.0f< >1234.875< >1235< ->%.1f< >1234.875< >1234.9< ->%-8.1f< >1234.875< >1234.9 < ->%8.1f< >1234.875< > 1234.9< ->%+-8.1f< >1234.875< >+1234.9 < ->%+8.1f< >1234.875< > +1234.9< ->%+-8.1f< >-1234.875< >-1234.9 < ->%+8.1f< >-1234.875< > -1234.9< ->%*.*f< >[5, 2, 12.3456]< >12.35< ->%f< >0< >0.000000< ->%.0f< >0< >0< ->%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< ->%.0f< >0.1< >0< ->%.0f< >0.6< >1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< ->%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< ->%.0f< >1< >1< ->%#.0f< >1< >1.< ->%g< >12345.6789< >12345.7< ->%+g< >12345.6789< >+12345.7< ->%#g< >12345.6789< >12345.7< ->%.0g< >12345.6789< >1e+04< ->%#.0g< >12345.6789< >1.e+04< ->%.2g< >12345.6789< >1.2e+04< ->%.*g< >[2, 12345.6789]< >1.2e+04< ->%.9g< >12345.6789< >12345.6789< ->%12.9g< >12345.6789< > 12345.6789< ->%012.9g< >12345.6789< >0012345.6789< ->%-12.9g< >12345.6789< >12345.6789 < ->%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < ->%-012.9g< >12345.6789< >12345.6789 < ->%g< >-12345.6789< >-12345.7< ->%+g< >-12345.6789< >-12345.7< ->%g< >1234567.89< >1.23457e+06< ->%+g< >1234567.89< >+1.23457e+06< ->%#g< >1234567.89< >1.23457e+06< ->%g< >-1234567.89< >-1.23457e+06< ->%+g< >-1234567.89< >-1.23457e+06< ->%#g< >-1234567.89< >-1.23457e+06< ->%g< >0.00012345< >0.00012345< ->%g< >0.000012345< >1.2345e-05< ->%g< >1234567E96< >1.23457e+102< ->%g< >.1234567E-101< >1.23457e-102< ->%g< >0< >0< ->%13g< >1234567.89< > 1.23457e+06< ->%+13g< >1234567.89< > +1.23457e+06< ->%013g< >1234567.89< >001.23457e+06< ->%-13g< >1234567.89< >1.23457e+06 < ->%h< >''< >%h INVALID< ->%i< >123456.789< >123456< >Synonym for %d< ->%j< >''< >%j INVALID< ->%k< >''< >%k INVALID< ->%l< >''< >%l INVALID< ->%m< >''< >%m INVALID< ->%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< ->%o< >2**32-1< >37777777777< ->%+o< >2**32-1< >37777777777< ->%#o< >2**32-1< >037777777777< ->%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< ->%#p< >''< >%#p INVALID< ->%q< >''< >%q INVALID< ->%r< >''< >%r INVALID< ->%s< >'string'< >string< ->%10s< >'string'< > string< ->%+10s< >'string'< > string< ->%#10s< >'string'< > string< ->%010s< >'string'< >0000string< ->%0*s< >[10, 'string']< >0000string< ->%-10s< >'string'< >string < ->%3s< >'string'< >string< ->%.3s< >'string'< >str< ->%.*s< >[3, 'string']< >str< ->%t< >''< >%t INVALID< ->%u< >2**32-1< >4294967295< ->%+u< >2**32-1< >4294967295< ->%#u< >2**32-1< >4294967295< ->%12u< >2**32-1< > 4294967295< ->%012u< >2**32-1< >004294967295< ->%-12u< >2**32-1< >4294967295 < ->%-012u< >2**32-1< >4294967295 < ->%v< >''< >%v INVALID< ->%w< >''< >%w INVALID< ->%x< >2**32-1< >ffffffff< ->%+x< >2**32-1< >ffffffff< ->%#x< >2**32-1< >0xffffffff< ->%10x< >2**32-1< > ffffffff< ->%010x< >2**32-1< >00ffffffff< ->%-10x< >2**32-1< >ffffffff < ->%-010x< >2**32-1< >ffffffff < ->%0-10x< >2**32-1< >ffffffff < ->%0*x< >[-10, ,2**32-1]< >ffffffff < ->%y< >''< >%y INVALID< ->%z< >''< >%z INVALID< diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t deleted file mode 100755 index 1d8c7a3..0000000 --- a/contrib/perl5/t/op/stat.t +++ /dev/null @@ -1,287 +0,0 @@ -#!./perl - -# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -print "1..58\n"; - -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_Dos = $^O eq 'dos'; -$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; -$Is_Cygwin = $^O eq 'cygwin'; -chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); - -$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; - -unlink "Op.stat.tmp"; -if (open(FOO, ">Op.stat.tmp")) { - # hack to make Apollo update link count: - $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat(FOO); - if ($nlink == 1) { - print "ok 1\n"; - } - else { - print "# res=$res, nlink=$nlink.\nnot ok 1\n"; - } - if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) { - print "ok 2\n"; - } - else { - print "# |$mtime| vs |$ctime|\nnot ok 2\n"; - } - - my $funky_FAT_timestamps = $Is_Cygwin; - - sleep 3 if $funky_FAT_timestamps; - - print FOO "Now is the time for all good men to come to.\n"; - close(FOO); - - sleep 2 unless $funky_FAT_timestamps; - -} else { - print "# open failed: $!\nnot ok 1\nnot ok 2\n"; -} - -if ($Is_Dosish) { unlink "Op.stat.tmp2"} -else { - `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; -} - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.stat.tmp'); - -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 ( $Is_Dosish - # Solaris tmpfs bug - || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris') - || $cwd =~ m#/afs/# - || $^O eq 'amigaos') { - print "ok 4 # skipped: different semantic of mtime/ctime\n"; -} -elsif ( ($mtime && $mtime != $ctime) ) { - print "ok 4\n"; -} -else { - print "not ok 4\n"; - print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; - print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; - print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; -} -print "#4 :$mtime: should != :$ctime:\n"; - -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` } - -if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";} -if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";} - -$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' 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'; -eval '$> = 1;'; # so switch uid (may not be implemented) -if (!$> || $Is_Dos || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";} -if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";} -eval '$> = $olduid;'; # switch uid back (may not be implemented) -print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid); - -if (! -x 'Op.stat.tmp') {print "ok 11\n";} -else {print "not ok 11\n";} - -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_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";} - -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_Dosish and `ls -l perl` =~ /^l.*->/) { - if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";} -} -else { - print "ok 25\n"; -} - -if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";} - -if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";} -unlink 'Op.stat.tmp2'; -if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 29\n";} -elsif ($DEV !~ /\nc.* (\S+)\n/) - {print "ok 29\n";} -elsif (-c "/dev/$1") - {print "ok 29\n";} -else - {print "not ok 29\n";} -if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 31\n";} -elsif ($DEV !~ /\ns.* (\S+)\n/) - {print "ok 31\n";} -elsif (-S "/dev/$1") - {print "ok 31\n";} -else - {print "not ok 31\n";} -if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 33\n";} -elsif ($DEV !~ /\nb.* (\S+)\n/) - {print "ok 33\n";} -elsif (-b "/dev/$1") - {print "ok 33\n";} -else - {print "not ok 33\n";} -if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} - -if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { - print "ok 35 # skipped: no -u\n"; goto tty_test; -} - -$cnt = $uid = 0; - -die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -my @bin = grep {-d} ($^O eq 'machten' ? - qw(/usr/bin /bin) : - qw(/sbin /usr/sbin /bin /usr/bin)); -unless (@bin) { print ("not ok 35\n"), goto tty_test; } -for my $bin (@bin) { - opendir BIN, $bin or die "Can't opendir $bin: $!"; - while (defined($_ = readdir BIN)) { - $_ = "$bin/$_"; - $cnt++; - $uid++ if -u; - last if $uid && $uid < $cnt; - } -} -closedir BIN; - -# I suppose this is going to fail somewhere... -if ($uid > 0 && $uid < $cnt) - {print "ok 35\n";} -else - {print "not ok 35 \n# ($uid $cnt)\n";} - -tty_test: - -# To assist in automated testing when a controlling terminal (/dev/tty) -# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var -# can be set to skip the tests that need a tty. -unless($ENV{PERL_SKIP_TTY_TEST}) { - if ($Is_MSWin32) { - print "ok 36\n"; - print "ok 37\n"; - } - else { - 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 38\n";} else {print "not ok 38\n";} - if (-t) {print "ok 39\n";} else {print "not ok 39\n";} -} -else { - print "ok 36\n"; - print "ok 37\n"; - print "ok 38\n"; - print "ok 39\n"; -} -open(null,"/dev/null"); -if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32) - {print "ok 40\n";} else {print "not ok 40\n";} -close(null); - -# These aren't strictly "stat" calls, but so what? - -if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";} -if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";} - -if (-B './perl' || -B './perl.exe') {print "ok 43\n";} else {print "not ok 43\n";} -if (! -T './perl' && ! -T './perl.exe') {print "ok 44\n";} else {print "not ok 44\n";} - -open(FOO,'op/stat.t'); -eval { -T FOO; }; -if ($@ =~ /not implemented/) { - print "# $@"; - for (45 .. 54) { - print "ok $_\n"; - } -} -else { - if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";} - if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";} - $_ = <FOO>; - if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";} - if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";} - if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";} - close(FOO); - - open(FOO,'op/stat.t'); - $_ = <FOO>; - if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";} - if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";} - if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";} - seek(FOO,0,0); - if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";} - if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";} -} -close(FOO); - -if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";} -if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";} - -# and now, a few parsing tests: -$_ = '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' or print "# unlink failed: $!\n"; diff --git a/contrib/perl5/t/op/study.t b/contrib/perl5/t/op/study.t deleted file mode 100755 index ea3b366..0000000 --- a/contrib/perl5/t/op/study.t +++ /dev/null @@ -1,69 +0,0 @@ -#!./perl - -# $RCSfile: study.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:30 $ - -print "1..24\n"; - -$x = "abc\ndef\n"; -study($x); - -if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} -if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} - -$* = 1; -if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} -$* = 0; - -$_ = '123'; -study; -if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} - -if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} -if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} - -if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} -if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} - -study($x); -if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} -if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} - -if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} -if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} - -$_ = 'aaabbbccc'; -study; -if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { - print "ok 13\n"; -} else { - print "not ok 13\n"; -} -if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { - print "ok 14\n"; -} else { - print "not ok 14\n"; -} - -if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} - -$_ = 'aaabccc'; -study; -if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} -if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} - -$_ = 'aaaccc'; -study; -if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} -if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} - -$_ = 'abcdef'; -study; -if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} -if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} - -if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} - -if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} - -$* = 1; # test 3 only tested the optimized version--this one is for real -if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";} diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t deleted file mode 100755 index 7dd7a1c..0000000 --- a/contrib/perl5/t/op/subst.t +++ /dev/null @@ -1,381 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..84\n"; - -$x = 'foo'; -$_ = "x"; -s/x/\$x/; -print "#1\t:$_: eq :\$x:\n"; -if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} - -$_ = "x"; -s/x/$x/; -print "#2\t:$_: eq :foo:\n"; -if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = "x"; -s/x/\$x $x/; -print "#3\t:$_: eq :\$x foo:\n"; -if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} - -$b = 'cd'; -($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; -print "#4\t:$1: eq :bcde:\n"; -print "#4\t:$a: eq :a\\n\$1f:\n"; -if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";} - -$a = 'abacada'; -if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') - {print "ok 5\n";} else {print "not ok 5\n";} - -if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') - {print "ok 6\n";} else {print "not ok 6 $a\n";} - -if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') - {print "ok 7\n";} else {print "not ok 7 $a\n";} - -$_ = 'ABACADA'; -if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";} - -$_ = '\\' x 4; -if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";} -s/\\/\\\\/g; -if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";} - -$_ = '\/' x 4; -if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";} -s/\//\/\//g; -if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";} -if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";} - -$_ = 'aaaXXXXbbb'; -s/^a//; -print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n"; - -$_ = 'aaaXXXXbbb'; -s/a//; -print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n"; - -$_ = 'aaaXXXXbbb'; -s/^a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n"; - -$_ = 'aaaXXXXbbb'; -s/a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n"; - -$_ = 'aaaXXXXbbb'; -s/aa//; -print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n"; - -$_ = 'aaaXXXXbbb'; -s/aa/b/; -print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n"; - -$_ = 'aaaXXXXbbb'; -s/b$//; -print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n"; - -$_ = 'aaaXXXXbbb'; -s/b//; -print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n"; - -$_ = 'aaaXXXXbbb'; -s/bb//; -print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n"; - -$_ = 'aaaXXXXbbb'; -s/aX/y/; -print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n"; - -$_ = 'aaaXXXXbbb'; -s/Xb/z/; -print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n"; - -$_ = 'aaaXXXXbbb'; -s/aaX.*Xbb//; -print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n"; - -$_ = 'aaaXXXXbbb'; -s/bb/x/; -print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n"; - -# now for some unoptimized versions of the same. - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a//; -print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a//; -print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa//; -print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa/b/; -print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b$//; -print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b//; -print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb//; -print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aX/y/; -print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/Xb/z/; -print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aaX.*Xbb//; -print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb/x/; -print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; - -$_ = 'abc123xyz'; -s/(\d+)/$1*2/e; # yields 'abc246xyz' -print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; -s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' -print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; -s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' -print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n"; - -$_ = "aaaaa"; -print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n"; -print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n"; -print y/b// == 5 ? "ok 45\n" : "not ok 45\n"; -print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n"; -print y/c// == 1 ? "ok 47\n" : "not ok 47\n"; -print y/c//d == 1 ? "ok 48\n" : "not ok 48\n"; -print $_ eq "" ? "ok 49\n" : "not ok 49\n"; - -$_ = "Now is the %#*! time for all good men..."; -print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n"); -print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n"; - -$_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; -tr/a-z/A-Z/; - -print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; - -# same as tr/A-Z/a-z/; -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"; - -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/; -print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n"; - -$_ = '+,-'; -tr/-+,/ab\-/; -print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n"; - - -# test recursive substitutions -# code based on the recursive expansion of makefile variables - -my %MK = ( - AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short - E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long - DIR => '$(UNDEFINEDNAME)/xxx', -); -sub var { - my($var,$level) = @_; - return "\$($var)" unless exists $MK{$var}; - return exp_vars($MK{$var}, $level+1); # can recurse -} -sub exp_vars { - my($str,$level) = @_; - $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse - #warn "exp_vars $level = '$str'\n"; - $str; -} - -print exp_vars('$(AAAAA)',0) eq 'D' - ? "ok 57\n" : "not ok 57\n"; -print exp_vars('$(E)',0) eq 'p HHHHH q' - ? "ok 58\n" : "not ok 58\n"; -print exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' - ? "ok 59\n" : "not ok 59\n"; -print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' - ? "ok 60\n" : "not ok 60\n"; - -# a match nested in the RHS of a substitution: - -$_ = "abcd"; -s/(..)/$x = $1, m#.#/eg; -print $x eq "cd" ? "ok 61\n" : "not ok 61\n"; - -# Subst and lookbehind - -$_="ccccc"; -s/(?<!x)c/x/g; -print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n"; - -$_="ccccc"; -s/(?<!x)(c)/x/g; -print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n"; - -$_="foobbarfoobbar"; -s/(?<!r)foobbar/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n"; - -$_="foobbarfoobbar"; -s/(?<!ar)(foobbar)/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n"; - -$_="foobbarfoobbar"; -s/(?<!ar)foobbar/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n"; - -# check parsing of split subst with comment -eval 's{foo} # this is a comment, not a delimiter - {bar};'; -print @? ? "not ok 67\n" : "ok 67\n"; - -# check if squashing works at the end of string -$_="baacbaa"; -tr/a/b/s; -print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n"; - -# XXX TODO: Most tests above don't test return values of the ops. They should. -$_ = "ab"; -print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n"); - -$_ = <<'EOL'; - $url = new URI::URL "http://www/"; die if $url eq "xXx"; -EOL -$^R = 'junk'; - -$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' . - ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' . - ' lowercase $@%#MiXeD$@%# '; - -s{ \d+ \b [,.;]? (?{ 'digits' }) - | - [a-z]+ \b [,.;]? (?{ 'lowercase' }) - | - [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' }) - | - [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' }) - | - [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' }) - | - [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' }) - | - \s+ (?{ ' ' }) - | - [^A-Za-z0-9\s]+ (?{ '$@%#' }) -}{$^R}xg; -print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n"); - -$_ = 'x' x 20; -s/(\d*|x)/<$1>/g; -$foo = '<>' . ('<x><>' x 20) ; -print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); - -$t = 'aaaaaaaaa'; - -$_ = $t; -pos = 6; -s/\Ga/xx/g; -print "not " unless $_ eq 'aaaaaaxxxxxx'; -print "ok 72\n"; - -$_ = $t; -pos = 6; -s/\Ga/x/g; -print "not " unless $_ eq 'aaaaaaxxx'; -print "ok 73\n"; - -$_ = $t; -pos = 6; -s/\Ga/xx/; -print "not " unless $_ eq 'aaaaaaxxaa'; -print "ok 74\n"; - -$_ = $t; -pos = 6; -s/\Ga/x/; -print "not " unless $_ eq 'aaaaaaxaa'; -print "ok 75\n"; - -$_ = $t; -s/\Ga/xx/g; -print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx'; -print "ok 76\n"; - -$_ = $t; -s/\Ga/x/g; -print "not " unless $_ eq 'xxxxxxxxx'; -print "ok 77\n"; - -$_ = $t; -s/\Ga/xx/; -print "not " unless $_ eq 'xxaaaaaaaa'; -print "ok 78\n"; - -$_ = $t; -s/\Ga/x/; -print "not " unless $_ eq 'xaaaaaaaa'; -print "ok 79\n"; - -$_ = 'aaaa'; -s/\ba/./g; -print "#'$_'\nnot " unless $_ eq '.aaa'; -print "ok 80\n"; - -eval q% s/a/"b"}/e %; -print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n"); -eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; -print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n"; -$x = $x = 'interp'; -eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; -print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; - -$_ = "C:/"; -s/^([a-z]:)/\u$1/ and print "not "; -print "ok 84\n"; - diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t deleted file mode 100755 index 7189572..0000000 --- a/contrib/perl5/t/op/subst_amp.t +++ /dev/null @@ -1,104 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..13\n"; - -$_ = 'x' x 20; -s/\d*|x/<$&>/g; -$foo = '<>' . ('<x><>' x 20) ; -print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n"); - -$t = 'aaa'; - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/xx/g; -print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa'; -print "ok 2\n"; - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/x/g; -print "not " unless "$_ @res" eq 'axx aaa a aaa aa'; -print "ok 3\n"; - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/xx/; -print "not " unless "$_ @res" eq 'axxa aaa a'; -print "ok 4\n"; - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/x/; -print "not " unless "$_ @res" eq 'axa aaa a'; -print "ok 5\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/xx/g; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; -print "ok 6\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x/g; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; -print "ok 7\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/xx/; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; -print "ok 8\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x/; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; -print "ok 9\n"; - -sub x2 {'xx'} -sub x1 {'x'} - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; -print "ok 10\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; -print "ok 11\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x2/e; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; -print "ok 12\n"; - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x1/e; -print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; -print "ok 13\n"; - diff --git a/contrib/perl5/t/op/subst_wamp.t b/contrib/perl5/t/op/subst_wamp.t deleted file mode 100755 index b716b30..0000000 --- a/contrib/perl5/t/op/subst_wamp.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -$dummy = defined $&; # Now we have it... -for $file ('op/subst.t', 't/op/subst.t') { - if (-r $file) { - do $file; - exit; - } -} -die "Cannot find op/subst.t or t/op/subst.t\n"; - diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t deleted file mode 100755 index 85574d5..0000000 --- a/contrib/perl5/t/op/substr.t +++ /dev/null @@ -1,587 +0,0 @@ -#!./perl - -print "1..174\n"; - -#P = start of string Q = start of substr R = end of substr S = end of string - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -use warnings ; - -$a = 'abcdefxyz'; -$SIG{__WARN__} = sub { - if ($_[0] =~ /^substr outside of string/) { - $w++; - } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { - $w += 2; - } elsif ($_[0] =~ /^Use of uninitialized value/) { - $w += 3; - } else { - warn $_[0]; - } -}; - -sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") } - -$FATAL_MSG = '^substr outside of string' ; - -ok 1, substr($a,0,3) eq 'abc'; # P=Q R S -ok 2, substr($a,3,3) eq 'def'; # P Q R S -ok 3, substr($a,6,999) eq 'xyz'; # P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -ok 4, $w-- == 1 ; -eval{substr($a,999,999) = "" ; };# P R Q S -ok 5, $@ =~ /$FATAL_MSG/; -ok 6, substr($a,0,-6) eq 'abc'; # P=Q R S -ok 7, substr($a,-3,1) eq 'x'; # P Q R S - -$[ = 1; - -ok 8, substr($a,1,3) eq 'abc' ; # P=Q R S -ok 9, substr($a,4,3) eq 'def' ; # P Q R S -ok 10, substr($a,7,999) eq 'xyz';# P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -ok 11, $w-- == 1 ; -eval{substr($a,999,999) = "" ; } ; # P R Q S -ok 12, $@ =~ /$FATAL_MSG/; -ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S -ok 14, substr($a,-3,1) eq 'x' ; # P Q R S - -$[ = 0; - -substr($a,3,3) = 'XYZ'; -ok 15, $a eq 'abcXYZxyz' ; -substr($a,0,2) = ''; -ok 16, $a eq 'cXYZxyz' ; -substr($a,0,0) = 'ab'; -ok 17, $a eq 'abcXYZxyz' ; -substr($a,0,0) = '12345678'; -ok 18, $a eq '12345678abcXYZxyz' ; -substr($a,-3,3) = 'def'; -ok 19, $a eq '12345678abcXYZdef'; -substr($a,-3,3) = '<'; -ok 20, $a eq '12345678abcXYZ<' ; -substr($a,-1,1) = '12345678'; -ok 21, $a eq '12345678abcXYZ12345678' ; - -$a = 'abcdefxyz'; - -ok 22, substr($a,6) eq 'xyz' ; # P Q R=S -ok 23, substr($a,-3) eq 'xyz' ; # P Q R=S -$b = substr($a,999,999) ; # warning # P R=S Q -ok 24, $w-- == 1 ; -eval{substr($a,999,999) = "" ; } ; # P R=S Q -ok 25, $@ =~ /$FATAL_MSG/; -ok 26, substr($a,0) eq 'abcdefxyz' ; # P=Q R=S -ok 27, substr($a,9) eq '' ; # P Q=R=S -ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S -ok 29, substr($a,-9) eq 'abcdefxyz'; # P=Q R=S - -$a = '54321'; - -$b = substr($a,-7, 1) ; # warn # Q R P S -ok 30, $w-- == 1 ; -eval{substr($a,-7, 1) = "" ; }; # Q R P S -ok 31, $@ =~ /$FATAL_MSG/; -$b = substr($a,-7,-6) ; # warn # Q R P S -ok 32, $w-- == 1 ; -eval{substr($a,-7,-6) = "" ; }; # Q R P S -ok 33, $@ =~ /$FATAL_MSG/; -ok 34, substr($a,-5,-7) eq ''; # R P=Q S -ok 35, substr($a, 2,-7) eq ''; # R P Q S -ok 36, substr($a,-3,-7) eq ''; # R P Q S -ok 37, substr($a, 2,-5) eq ''; # P=R Q S -ok 38, substr($a,-3,-5) eq ''; # P=R Q S -ok 39, substr($a, 2,-4) eq ''; # P R Q S -ok 40, substr($a,-3,-4) eq ''; # P R Q S -ok 41, substr($a, 5,-6) eq ''; # R P Q=S -ok 42, substr($a, 5,-5) eq ''; # P=R Q S -ok 43, substr($a, 5,-3) eq ''; # P R Q=S -$b = substr($a, 7,-7) ; # warn # R P S Q -ok 44, $w-- == 1 ; -eval{substr($a, 7,-7) = "" ; }; # R P S Q -ok 45, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7,-5) ; # warn # P=R S Q -ok 46, $w-- == 1 ; -eval{substr($a, 7,-5) = "" ; }; # P=R S Q -ok 47, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7,-3) ; # warn # P Q S Q -ok 48, $w-- == 1 ; -eval{substr($a, 7,-3) = "" ; }; # P Q S Q -ok 49, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7, 0) ; # warn # P S Q=R -ok 50, $w-- == 1 ; -eval{substr($a, 7, 0) = "" ; }; # P S Q=R -ok 51, $@ =~ /$FATAL_MSG/; - -ok 52, substr($a,-7,2) eq ''; # Q P=R S -ok 53, substr($a,-7,4) eq '54'; # Q P R S -ok 54, substr($a,-7,7) eq '54321';# Q P R=S -ok 55, substr($a,-7,9) eq '54321';# Q P S R -ok 56, substr($a,-5,0) eq ''; # P=Q=R S -ok 57, substr($a,-5,3) eq '543';# P=Q R S -ok 58, substr($a,-5,5) eq '54321';# P=Q R=S -ok 59, substr($a,-5,7) eq '54321';# P=Q S R -ok 60, substr($a,-3,0) eq ''; # P Q=R S -ok 61, substr($a,-3,3) eq '321';# P Q R=S -ok 62, substr($a,-2,3) eq '21'; # P Q S R -ok 63, substr($a,0,-5) eq ''; # P=Q=R S -ok 64, substr($a,2,-3) eq ''; # P Q=R S -ok 65, substr($a,0,0) eq ''; # P=Q=R S -ok 66, substr($a,0,5) eq '54321';# P=Q R=S -ok 67, substr($a,0,7) eq '54321';# P=Q S R -ok 68, substr($a,2,0) eq ''; # P Q=R S -ok 69, substr($a,2,3) eq '321'; # P Q R=S -ok 70, substr($a,5,0) eq ''; # P Q=R=S -ok 71, substr($a,5,2) eq ''; # P Q=S R -ok 72, substr($a,-7,-5) eq ''; # Q P=R S -ok 73, substr($a,-7,-2) eq '543';# Q P R S -ok 74, substr($a,-5,-5) eq ''; # P=Q=R S -ok 75, substr($a,-5,-2) eq '543';# P=Q R S -ok 76, substr($a,-3,-3) eq ''; # P Q=R S -ok 77, substr($a,-3,-1) eq '32';# P Q R S - -$a = ''; - -ok 78, substr($a,-2,2) eq ''; # Q P=R=S -ok 79, substr($a,0,0) eq ''; # P=Q=R=S -ok 80, substr($a,0,1) eq ''; # P=Q=S R -ok 81, substr($a,-2,3) eq ''; # Q P=S R -ok 82, substr($a,-2) eq ''; # Q P=R=S -ok 83, substr($a,0) eq ''; # P=Q=R=S - - -ok 84, substr($a,0,-1) eq ''; # R P=Q=S -$b = substr($a,-2, 0) ; # warn # Q=R P=S -ok 85, $w-- == 1 ; -eval{substr($a,-2, 0) = "" ; }; # Q=R P=S -ok 86, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2, 1) ; # warn # Q R P=S -ok 87, $w-- == 1 ; -eval{substr($a,-2, 1) = "" ; }; # Q R P=S -ok 88, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2,-1) ; # warn # Q R P=S -ok 89, $w-- == 1 ; -eval{substr($a,-2,-1) = "" ; }; # Q R P=S -ok 90, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2,-2) ; # warn # Q=R P=S -ok 91, $w-- == 1 ; -eval{substr($a,-2,-2) = "" ; }; # Q=R P=S -ok 92, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1,-2) ; # warn # R P=S Q -ok 93, $w-- == 1 ; -eval{substr($a, 1,-2) = "" ; }; # R P=S Q -ok 94, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1, 1) ; # warn # P=S Q R -ok 95, $w-- == 1 ; -eval{substr($a, 1, 1) = "" ; }; # P=S Q R -ok 96, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1, 0) ;# warn # P=S Q=R -ok 97, $w-- == 1 ; -eval{substr($a, 1, 0) = "" ; }; # P=S Q=R -ok 98, $@ =~ /$FATAL_MSG/; - -$b = substr($a,1) ; # warning # P=R=S Q -ok 99, $w-- == 1 ; -eval{substr($a,1) = "" ; }; # P=R=S Q -ok 100, $@ =~ /$FATAL_MSG/; - -my $a = 'zxcvbnm'; -substr($a,2,0) = ''; -ok 101, $a eq 'zxcvbnm'; -substr($a,7,0) = ''; -ok 102, $a eq 'zxcvbnm'; -substr($a,5,0) = ''; -ok 103, $a eq 'zxcvbnm'; -substr($a,0,2) = 'pq'; -ok 104, $a eq 'pqcvbnm'; -substr($a,2,0) = 'r'; -ok 105, $a eq 'pqrcvbnm'; -substr($a,8,0) = 'asd'; -ok 106, $a eq 'pqrcvbnmasd'; -substr($a,0,2) = 'iop'; -ok 107, $a eq 'ioprcvbnmasd'; -substr($a,0,5) = 'fgh'; -ok 108, $a eq 'fghvbnmasd'; -substr($a,3,5) = 'jkl'; -ok 109, $a eq 'fghjklsd'; -substr($a,3,2) = '1234'; -ok 110, $a eq 'fgh1234lsd'; - - -# with lexicals (and in re-entered scopes) -for (0,1) { - my $txt; - unless ($_) { - $txt = "Foo"; - substr($txt, -1) = "X"; - ok 111, $txt eq "FoX"; - } - else { - substr($txt, 0, 1) = "X"; - ok 112, $txt eq "X"; - } -} - -$w = 0 ; -# coercion of references -{ - my $s = []; - substr($s, 0, 1) = 'Foo'; - ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2); -} - -# check no spurious warnings -ok 114, $w == 0; - -# check new 4 arg replacement syntax -$a = "abcxyz"; -$w = 0; -ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; -ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; -ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; - -ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" - && $w == 3; - -$w = 0; - -ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; -eval{substr($a, -99, 0, "") }; -ok 120, $@ =~ /$FATAL_MSG/; -eval{substr($a, 99, 3, "") }; -ok 121, $@ =~ /$FATAL_MSG/; - -substr($a, 0, length($a), "foo"); -ok 122, $a eq "foo" && !$w; - -# using 4 arg substr as lvalue is a compile time error -eval 'substr($a,0,0,"") = "abc"'; -ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; - -$a = "abcdefgh"; -ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; -ok 125, $a eq 'xxxxefgh'; - -{ - my $y = 10; - $y = "2" . $y; - ok 126, $y+0 == 210; -} - -# utf8 sanity -{ - my $x = substr("a\x{263a}b",0); - ok 127, length($x) == 3; - $x = substr($x,1,1); - ok 128, $x eq "\x{263a}"; - $x = $x x 2; - ok 129, length($x) == 2; - substr($x,0,1) = "abcd"; - ok 130, $x eq "abcd\x{263a}"; - ok 131, length($x) == 5; - $x = reverse $x; - ok 132, length($x) == 5; - ok 133, $x eq "\x{263a}dcba"; - - my $z = 10; - $z = "21\x{263a}" . $z; - ok 134, length($z) == 5; - ok 135, $z eq "21\x{263a}10"; -} - -# replacement should work on magical values -require Tie::Scalar; -my %data; -tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical -$data{a} = "firstlast"; -ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last"; - -# more utf8 - -# The following two originally from Ignasi Roca. - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} -ok 137, length($x) == 3 && - $x eq "\x{100}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} -ok 138, length($x) == 4 && - $x eq "\x{100}\x{FF}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -# more utf8 lval exercise - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 2) = "\x{100}\xFF"; -ok 139, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 1, 1) = "\x{100}\xFF"; -ok 140, length($x) == 4 && - $x eq "\xF1\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 2, 1) = "\x{100}\xFF"; -ok 141, length($x) == 4 && - $x eq "\xF1\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 3, 1) = "\x{100}\xFF"; -ok 142, length($x) == 5 && - $x eq "\xF1\xF2\xF3\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}" && - substr($x, 3, 1) eq "\x{100}" && - substr($x, 4, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 1) = "\x{100}\xFF"; -ok 143, length($x) == 4 && - $x eq "\xF1\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 0) = "\x{100}\xFF"; -ok 144, length($x) == 5 && - $x eq "\xF1\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -1) = "\x{100}\xFF"; -ok 145, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -2) = "\x{100}\xFF"; -ok 146, length($x) == 4 && - $x eq "\x{100}\xFF\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -3) = "\x{100}\xFF"; -ok 147, length($x) == 5 && - $x eq "\x{100}\xFF\xF1\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F1}" && - substr($x, 3, 1) eq "\x{F2}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 1, -1) = "\x{100}\xFF"; -ok 148, length($x) == 4 && - $x eq "\xF1\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, -1) = "\x{100}\xFF"; -ok 149, length($x) == 5 && - $x eq "\xF1\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -# And tests for already-UTF8 one - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}"; -ok 150, length($x) == 3 && - $x eq "\x{100}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}\x{FF}"; -ok 151, length($x) == 4 && - $x eq "\x{100}\x{FF}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 2) = "\x{100}\xFF"; -ok 152, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, 1) = "\x{100}\xFF"; -ok 153, length($x) == 4 && - $x eq "\x{101}\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 2, 1) = "\x{100}\xFF"; -ok 154, length($x) == 4 && - $x eq "\x{101}\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 3, 1) = "\x{100}\xFF"; -ok 155, length($x) == 5 && - $x eq "\x{101}\x{F2}\x{F3}\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}" && - substr($x, 3, 1) eq "\x{100}" && - substr($x, 4, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 1) = "\x{100}\xFF"; -ok 156, length($x) == 4 && - $x eq "\x{101}\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 0) = "\x{100}\xFF"; -ok 157, length($x) == 5 && - $x eq "\x{101}\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -1) = "\x{100}\xFF"; -ok 158, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -2) = "\x{100}\xFF"; -ok 159, length($x) == 4 && - $x eq "\x{100}\xFF\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -3) = "\x{100}\xFF"; -ok 160, length($x) == 5 && - $x eq "\x{100}\xFF\x{101}\x{F2}\x{F3}" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{101}" && - substr($x, 3, 1) eq "\x{F2}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, -1) = "\x{100}\xFF"; -ok 161, length($x) == 4 && - $x eq "\x{101}\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, -1) = "\x{100}\xFF"; -ok 162, length($x) == 5 && - $x eq "\x{101}\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -substr($x = "ab", 0, 0, "\x{100}\x{200}"); -ok 163, $x eq "\x{100}\x{200}ab"; - -substr($x = "\x{100}\x{200}", 0, 0, "ab"); -ok 164, $x eq "ab\x{100}\x{200}"; - -substr($x = "ab", 1, 0, "\x{100}\x{200}"); -ok 165, $x eq "a\x{100}\x{200}b"; - -substr($x = "\x{100}\x{200}", 1, 0, "ab"); -ok 166, $x eq "\x{100}ab\x{200}"; - -substr($x = "ab", 2, 0, "\x{100}\x{200}"); -ok 167, $x eq "ab\x{100}\x{200}"; - -substr($x = "\x{100}\x{200}", 2, 0, "ab"); -ok 168, $x eq "\x{100}\x{200}ab"; - -substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); -ok 169, $x eq "\x{100}\x{200}\xFFb"; - -substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); -ok 170, $x eq "\xFFb\x{100}\x{200}"; - -substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); -ok 171, $x eq "\xFF\x{100}\x{200}b"; - -substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); -ok 172, $x eq "\x{100}\xFFb\x{200}"; - -substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); -ok 173, $x eq "\xFFb\x{100}\x{200}"; - -substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); -ok 174, $x eq "\x{100}\x{200}\xFFb"; - diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t deleted file mode 100755 index e43f850..0000000 --- a/contrib/perl5/t/op/sysio.t +++ /dev/null @@ -1,210 +0,0 @@ -#!./perl - -print "1..39\n"; - -chdir('op') || chdir('t/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' || - $^O eq 'mpeix'); - -$x = 'abc'; - -# should not be able to do negative lengths -eval { sysread(I, $x, -1) }; -print 'not ' unless ($@ =~ /^Negative length /); -print "ok 1\n"; - -# $x should be intact -print 'not ' unless ($x eq 'abc'); -print "ok 2\n"; - -# should not be able to read before the buffer -eval { sysread(I, $x, 1, -4) }; -print 'not ' unless ($x eq 'abc'); -print "ok 3\n"; - -# $x should be intact -print 'not ' unless ($x eq 'abc'); -print "ok 4\n"; - -$a ='0123456789'; - -# default offset 0 -print 'not ' unless(sysread(I, $a, 3) == 3); -print "ok 5\n"; - -# $a should be as follows -print 'not ' unless ($a eq '#!.'); -print "ok 6\n"; - -# reading past the buffer should zero pad -print 'not ' unless(sysread(I, $a, 2, 5) == 2); -print "ok 7\n"; - -# the zero pad should be seen now -print 'not ' unless ($a eq "#!.\0\0/p"); -print "ok 8\n"; - -# try changing the last two characters of $a -print 'not ' unless(sysread(I, $a, 3, -2) == 3); -print "ok 9\n"; - -# the last two characters of $a should have changed (into three) -print 'not ' unless ($a eq "#!.\0\0erl"); -print "ok 10\n"; - -$outfile = 'sysio.out'; - -open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; - -select(O); $|=1; select(STDOUT); - -# cannot write negative lengths -eval { syswrite(O, $x, -1) }; -print 'not ' unless ($@ =~ /^Negative length /); -print "ok 11\n"; - -# $x still intact -print 'not ' unless ($x eq 'abc'); -print "ok 12\n"; - -# $outfile still intact -print 'not ' if (-s $outfile); -print "ok 13\n"; - -# should not be able to write from after the buffer -eval { syswrite(O, $x, 1, 3) }; -print 'not ' unless ($@ =~ /^Offset outside string /); -print "ok 14\n"; - -# $x still intact -print 'not ' unless ($x eq 'abc'); -print "ok 15\n"; - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -print 'not ' if (-s $outfile); -print "ok 16\n"; - -# should not be able to write from before the buffer - -eval { syswrite(O, $x, 1, -4) }; -print 'not ' unless ($@ =~ /^Offset outside string /); -print "ok 17\n"; - -# $x still intact -print 'not ' unless ($x eq 'abc'); -print "ok 18\n"; - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -print 'not ' if (-s $outfile); -print "ok 19\n"; - -# default offset 0 -print 'not ' unless (syswrite(O, $a, 2) == 2); -print "ok 20\n"; - -# $a still intact -print 'not ' unless ($a eq "#!.\0\0erl"); -print "ok 21\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 == 2); -print "ok 22\n"; - -# with offset -print 'not ' unless (syswrite(O, $a, 2, 5) == 2); -print "ok 23\n"; - -# $a still intact -print 'not ' unless ($a eq "#!.\0\0erl"); -print "ok 24\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 == 4); -print "ok 25\n"; - -# with negative offset and a bit too much length -print 'not ' unless (syswrite(O, $a, 5, -3) == 3); -print "ok 26\n"; - -# $a still intact -print 'not ' unless ($a eq "#!.\0\0erl"); -print "ok 27\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 == 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: $!"; - -$b = 'xyz'; - -# reading too much only return as much as available -print 'not ' unless (sysread(I, $b, 100) == 10); -print "ok 32\n"; -# this we should have -print 'not ' unless ($b eq '#!ererlabc'); -print "ok 33\n"; - -# test sysseek - -print 'not ' unless sysseek(I, 2, 0) == 2; -print "ok 34\n"; -sysread(I, $b, 3); -print 'not ' unless $b eq 'ere'; -print "ok 35\n"; - -print 'not ' unless sysseek(I, -2, 1) == 3; -print "ok 36\n"; -sysread(I, $b, 4); -print 'not ' unless $b eq 'rerl'; -print "ok 37\n"; - -print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; -print "ok 38\n"; -print 'not ' if defined sysseek(I, -1, 1); -print "ok 39\n"; - -close(I); - -unlink $outfile; - -chdir('..'); - -1; - -# eof diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t deleted file mode 100755 index 2958a37..0000000 --- a/contrib/perl5/t/op/taint.t +++ /dev/null @@ -1,735 +0,0 @@ -#!./perl -T -# -# Taint tests by Tom Phoenix <rootbeer@teleport.com>. -# -# I don't claim to know all about tainting. If anyone sees -# tests that I've missed here, please add them. But this is -# better than having no tests at all, right? -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../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 }; - -use vars qw($ipcsysv); # did we manage to load IPC::SysV? - -BEGIN { - if ($^O eq 'VMS' && !defined($Config{d_setenv})) { - $ENV{PATH} = $ENV{PATH}; - $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ - && ($Config{d_shm} || $Config{d_msg})) { - eval { require IPC::SysV }; - unless ($@) { - $ipcsysv++; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); - } - } -} - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_Dos = $^O eq 'dos'; -my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : - $Is_MSWin32 ? '.\perl' : './perl'; -my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; - -if ($Is_VMS) { - my (%old, $x); - for $x ('DCL$PATH', @MoreEnv) { - ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; - } - eval <<EndOfCleanup; - END { - \$ENV{PATH} = '' if $Config{d_setenv}; - warn "# Note: logical name 'PATH' may have been deleted\n"; - \@ENV{keys %old} = values %old; - } -EndOfCleanup -} - -# Sources of taint: -# The empty tainted value, for tainting strings -my $TAINT = substr($^X, 0, 0); -# A tainted zero, useful for tainting numbers -my $TAINT0 = 0 + $TAINT; - -# This taints each argument passed. All must be lvalues. -# Side effect: It also stringifies them. :-( -sub taint_these (@) { - for (@_) { $_ .= $TAINT } -} - -# How to identify taint when you see it -sub any_tainted (@) { - not eval { join("",@_), kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} -sub all_tainted (@) { - for (@_) { return 0 unless tainted $_ } - 1; -} - -sub test ($$;$) { - my($serial, $boolean, $diag) = @_; - if ($boolean) { - print "ok $serial\n"; - } else { - print "not ok $serial\n"; - for (split m/^/m, $diag) { - print "# $_"; - } - print "\n" unless - $diag eq '' - or substr($diag, -1) eq "\n"; - } -} - -# We need an external program to call. -my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$"); -END { unlink $ECHO } -open PROG, "> $ECHO" or die "Can't create $ECHO: $!"; -print PROG 'print "@ARGV\n"', "\n"; -close PROG; -my $echo = "$Invoke_Perl $ECHO"; - -print "1..155\n"; - -# First, let's make sure that Perl is checking the dangerous -# environment variables. Maybe they aren't set yet, so we'll -# taint them ourselves. -{ - $ENV{'DCL$PATH'} = '' if $Is_VMS; - - $ENV{PATH} = ''; - delete @ENV{@MoreEnv}; - $ENV{TERM} = 'dumb'; - - test 1, eval { `$echo 1` } eq "1\n"; - - if ($Is_MSWin32 || $Is_VMS || $Is_Dos) { - print "# Environment tainting tests skipped\n"; - for (2..5) { print "ok $_\n" } - } - else { - my @vars = ('PATH', @MoreEnv); - while (my $v = $vars[0]) { - local $ENV{$v} = $TAINT; - last if eval { `$echo 1` }; - last unless $@ =~ /^Insecure \$ENV{$v}/; - shift @vars; - } - test 2, !@vars, "\$$vars[0]"; - - # tainted $TERM is unsafe only if it contains metachars - local $ENV{TERM}; - $ENV{TERM} = 'e=mc2'; - test 3, eval { `$echo 1` } eq "1\n"; - $ENV{TERM} = 'e=mc2' . $TAINT; - test 4, eval { `$echo 1` } eq ''; - test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@; - } - - my $tmp; - if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { - print "# all directories are writeable\n"; - } - else { - $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(sys$scratch /tmp /var/tmp /usr/tmp), - @ENV{qw(TMP TEMP)})[0] - or print "# can't find world-writeable directory to test PATH\n"; - } - - if ($tmp) { - local $ENV{PATH} = $tmp; - test 6, eval { `$echo 1` } eq ''; - test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; - } - else { - for (6..7) { print "ok $_ # Skipped: all directories are writeable\n" } - } - - if ($Is_VMS) { - $ENV{'DCL$PATH'} = $TAINT; - test 8, eval { `$echo 1` } eq ''; - test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; - if ($tmp) { - $ENV{'DCL$PATH'} = $tmp; - test 10, eval { `$echo 1` } eq ''; - test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; - } - else { - for (10..11) { print "ok $_ # Skipped: can't find world-writeable directory to test DCL\$PATH\n" } - } - $ENV{'DCL$PATH'} = ''; - } - else { - for (8..11) { print "ok $_ # Skipped: This is not VMS\n"; } - } -} - -# Let's see that we can taint and untaint as needed. -{ - my $foo = $TAINT; - test 12, tainted $foo; - - # That was a sanity check. If it failed, stop the insanity! - die "Taint checks don't seem to be enabled" unless tainted $foo; - - $foo = "foo"; - test 13, not tainted $foo; - - taint_these($foo); - test 14, tainted $foo; - - my @list = 1..10; - test 15, not any_tainted @list; - taint_these @list[1,3,5,7,9]; - test 16, any_tainted @list; - test 17, all_tainted @list[1,3,5,7,9]; - test 18, not any_tainted @list[0,2,4,6,8]; - - ($foo) = $foo =~ /(.+)/; - test 19, not tainted $foo; - - $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 20, not tainted $foo; - test 21, $foo eq 'bar'; - - { - use re 'taint'; - - ($foo) = ('bar' . $TAINT) =~ /(.+)/; - test 22, tainted $foo; - test 23, $foo eq 'bar'; - - $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 24, tainted $foo; - test 25, $foo eq 'bar'; - } - - $foo = $1 if 'bar' =~ /(.+)$TAINT/; - test 26, tainted $foo; - test 27, $foo eq 'bar'; - - my $pi = 4 * atan2(1,1) + $TAINT0; - test 28, tainted $pi; - - ($pi) = $pi =~ /(\d+\.\d+)/; - test 29, not tainted $pi; - test 30, sprintf("%.5f", $pi) eq '3.14159'; -} - -# How about command-line arguments? The problem is that we don't -# always get some, so we'll run another process with some. -{ - my $arg = "./arg$$"; - open PROG, "> $arg" or die "Can't create $arg: $!"; - print PROG q{ - eval { join('', @ARGV), kill 0 }; - exit 0 if $@ =~ /^Insecure dependency/; - print "# Oops: \$@ was [$@]\n"; - exit 1; - }; - close PROG; - print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 31, !$?, "Exited with status $?"; - unlink $arg; -} - -# Reading from a file should be tainted -{ - my $file = './TEST'; - test 32, open(FILE, $file), "Couldn't open '$file': $!"; - - my $block; - sysread(FILE, $block, 100); - my $line = <FILE>; - close FILE; - test 33, tainted $block; - test 34, tainted $line; -} - -# Globs should be forbidden, except under VMS, -# which doesn't spawn an external program. -if (1 # built-in glob - or $Is_VMS) { - for (35..36) { print "ok $_\n"; } -} -else { - my @globs = eval { <*> }; - test 35, @globs == 0 && $@ =~ /^Insecure dependency/; - - @globs = eval { glob '*' }; - test 36, @globs == 0 && $@ =~ /^Insecure dependency/; -} - -# Output of commands should be tainted -{ - my $foo = `$echo abc`; - test 37, tainted $foo; -} - -# Certain system variables should be tainted -{ - test 38, all_tainted $^X, $0; -} - -# Results of matching should all be untainted -{ - my $foo = "abcdefghi" . $TAINT; - test 39, tainted $foo; - - $foo =~ /def/; - test 40, not any_tainted $`, $&, $'; - - $foo =~ /(...)(...)(...)/; - test 41, not any_tainted $1, $2, $3, $+; - - my @bar = $foo =~ /(...)(...)(...)/; - test 42, not any_tainted @bar; - - test 43, tainted $foo; # $foo should still be tainted! - test 44, $foo eq "abcdefghi"; -} - -# Operations which affect files can't use tainted data. -{ - test 45, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 46, $@ =~ /^Insecure dependency/, $@; - - # There is no feature test in $Config{} for truncate, - # so we allow for the possibility that it's missing. - test 47, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 48, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - - test 49, eval { rename '', $TAINT } eq '', 'rename'; - test 50, $@ =~ /^Insecure dependency/, $@; - - test 51, eval { unlink $TAINT } eq '', 'unlink'; - test 52, $@ =~ /^Insecure dependency/, $@; - - test 53, eval { utime $TAINT } eq '', 'utime'; - test 54, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_chown}) { - test 55, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 56, $@ =~ /^Insecure dependency/, $@; - } - else { - for (55..56) { print "ok $_ # Skipped: chown() is not available\n" } - } - - if ($Config{d_link}) { - test 57, eval { link $TAINT, '' } eq '', 'link'; - test 58, $@ =~ /^Insecure dependency/, $@; - } - else { - for (57..58) { print "ok $_ # Skipped: link() is not available\n" } - } - - if ($Config{d_symlink}) { - test 59, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 60, $@ =~ /^Insecure dependency/, $@; - } - else { - for (59..60) { print "ok $_ # Skipped: symlink() is not available\n" } - } -} - -# Operations which affect directories can't use tainted data. -{ - test 61, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 62, $@ =~ /^Insecure dependency/, $@; - - test 63, eval { rmdir $TAINT } eq '', 'rmdir'; - test 64, $@ =~ /^Insecure dependency/, $@; - - test 65, eval { chdir $TAINT } eq '', 'chdir'; - test 66, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_chroot}) { - test 67, eval { chroot $TAINT } eq '', 'chroot'; - test 68, $@ =~ /^Insecure dependency/, $@; - } - else { - for (67..68) { print "ok $_ # Skipped: chroot() is not available\n" } - } -} - -# Some operations using files can't use tainted data. -{ - my $foo = "imaginary library" . $TAINT; - test 69, eval { require $foo } eq '', 'require'; - test 70, $@ =~ /^Insecure dependency/, $@; - - my $filename = "./taintB$$"; # NB: $filename isn't tainted! - END { unlink $filename if defined $filename } - $foo = $filename . $TAINT; - unlink $filename; # in any case - - test 71, eval { open FOO, $foo } eq '', 'open for read'; - test 72, $@ eq '', $@; # NB: This should be allowed - - # 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/, $@; -} - -# Commands to the system can't use tainted data -{ - my $foo = $TAINT; - - if ($^O eq 'amigaos') { - for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" } - } - else { - test 76, eval { open FOO, "| x$foo" } eq '', 'popen to'; - test 77, $@ =~ /^Insecure dependency/, $@; - - test 78, eval { open FOO, "x$foo |" } eq '', 'popen from'; - test 79, $@ =~ /^Insecure dependency/, $@; - } - - test 80, eval { exec $TAINT } eq '', 'exec'; - test 81, $@ =~ /^Insecure dependency/, $@; - - test 82, eval { system $TAINT } eq '', 'system'; - test 83, $@ =~ /^Insecure dependency/, $@; - - $foo = "*"; - taint_these $foo; - - test 84, eval { `$echo 1$foo` } eq '', 'backticks'; - test 85, $@ =~ /^Insecure dependency/, $@; - - if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 86, join('', eval { glob $foo } ) ne '', 'globbing'; - test 87, $@ eq '', $@; - } - else { - for (86..87) { print "ok $_ # Skipped: this is not VMS\n"; } - } -} - -# Operations which affect processes can't use tainted data. -{ - test 88, eval { kill 0, $TAINT } eq '', 'kill'; - test 89, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_setpgrp}) { - test 90, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 91, $@ =~ /^Insecure dependency/, $@; - } - else { - for (90..91) { print "ok $_ # Skipped: setpgrp() is not available\n" } - } - - if ($Config{d_setprior}) { - test 92, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 93, $@ =~ /^Insecure dependency/, $@; - } - else { - for (92..93) { print "ok $_ # Skipped: setpriority() is not available\n" } - } -} - -# Some miscellaneous operations can't use tainted data. -{ - if ($Config{d_syscall}) { - test 94, eval { syscall $TAINT } eq '', 'syscall'; - test 95, $@ =~ /^Insecure dependency/, $@; - } - else { - for (94..95) { print "ok $_ # Skipped: syscall() is not available\n" } - } - - { - my $foo = "x" x 979; - taint_these $foo; - local *FOO; - my $temp = "./taintC$$"; - END { unlink $temp } - test 96, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - - test 97, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 98, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_fcntl}) { - test 99, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 100, $@ =~ /^Insecure dependency/, $@; - } - else { - for (99..100) { print "ok $_ # Skipped: fcntl() is not available\n" } - } - - close FOO; - } -} - -# Some tests involving references -{ - my $foo = 'abc' . $TAINT; - my $fooref = \$foo; - test 101, not tainted $fooref; - test 102, tainted $$fooref; - test 103, tainted $foo; -} - -# Some tests involving assignment -{ - my $foo = $TAINT0; - my $bar = $foo; - test 104, all_tainted $foo, $bar; - test 105, tainted($foo = $bar); - test 106, tainted($bar = $bar); - test 107, tainted($bar += $bar); - test 108, tainted($bar -= $bar); - test 109, tainted($bar *= $bar); - test 110, tainted($bar++); - test 111, tainted($bar /= $bar); - test 112, tainted($bar += 0); - test 113, tainted($bar -= 2); - test 114, tainted($bar *= -1); - test 115, tainted($bar /= 1); - test 116, tainted($bar--); - test 117, $bar == 0; -} - -# Test assignment and return of lists -{ - my @foo = ("A", "tainted" . $TAINT, "B"); - test 118, not tainted $foo[0]; - test 119, tainted $foo[1]; - test 120, not tainted $foo[2]; - my @bar = @foo; - test 121, not tainted $bar[0]; - test 122, tainted $bar[1]; - test 123, not tainted $bar[2]; - my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 124, not tainted $baz[0]; - test 125, tainted $baz[1]; - test 126, not tainted $baz[2]; - my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 127, not tainted $plugh[0]; - test 128, tainted $plugh[1]; - test 129, not tainted $plugh[2]; - my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 130, not tainted ((&$nautilus)[0]); - test 131, tainted ((&$nautilus)[1]); - test 132, not tainted ((&$nautilus)[2]); - my @xyzzy = &$nautilus; - test 133, not tainted $xyzzy[0]; - test 134, tainted $xyzzy[1]; - test 135, not tainted $xyzzy[2]; - my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 136, not tainted ((&$red_october)[0]); - test 137, tainted ((&$red_october)[1]); - test 138, not tainted ((&$red_october)[2]); - my @corge = &$red_october; - test 139, not tainted $corge[0]; - test 140, tainted $corge[1]; - test 141, not tainted $corge[2]; -} - -# Test for system/library calls returning string data of dubious origin. -{ - # No reliable %Config check for getpw* - if (eval { setpwent(); getpwent(); 1 }) { - setpwent(); - my @getpwent = getpwent(); - die "getpwent: $!\n" unless (@getpwent); - test 142,( not tainted $getpwent[0] - and tainted $getpwent[1] - and not tainted $getpwent[2] - and not tainted $getpwent[3] - and not tainted $getpwent[4] - and not tainted $getpwent[5] - and tainted $getpwent[6] # ge?cos - and not tainted $getpwent[7] - and tainted $getpwent[8]); # shell - endpwent(); - } else { - for (142) { print "ok $_ # Skipped: getpwent() is not available\n" } - } - - if ($Config{d_readdir}) { # pretty hard to imagine not - local(*D); - opendir(D, "op") or die "opendir: $!\n"; - my $readdir = readdir(D); - test 143, tainted $readdir; - closedir(OP); - } else { - for (143) { print "ok $_ # Skipped: readdir() is not available\n" } - } - - if ($Config{d_readlink} && $Config{d_symlink}) { - my $symlink = "sl$$"; - unlink($symlink); - symlink("/something/naughty", $symlink) or die "symlink: $!\n"; - my $readlink = readlink($symlink); - test 144, tainted $readlink; - unlink($symlink); - } else { - for (144) { print "ok $_ # Skipped: readlink() or symlink() is not available\n"; } - } -} - -# test bitwise ops (regression bug) -{ - my $why = "y"; - my $j = "x" | $why; - test 145, not tainted $j; - $why = $TAINT."y"; - $j = "x" | $why; - test 146, tainted $j; -} - -# test target of substitution (regression bug) -{ - my $why = $TAINT."y"; - $why =~ s/y/z/; - test 147, tainted $why; - - my $z = "[z]"; - $why =~ s/$z/zee/; - test 148, tainted $why; - - $why =~ s/e/'-'.$$/ge; - test 149, tainted $why; -} - -# test shmread -{ - unless ($ipcsysv) { - print "ok 150 # skipped: no IPC::SysV\n"; - last; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { - no strict 'subs'; - my $sent = "foobar"; - my $rcvd; - my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); - - if (defined $id) { - if (shmwrite($id, $sent, 0, 60)) { - if (shmread($id, $rcvd, 0, 60)) { - substr($rcvd, index($rcvd, "\0")) = ''; - } else { - warn "# shmread failed: $!\n"; - } - } else { - warn "# shmwrite failed: $!\n"; - } - shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; - } else { - warn "# shmget failed: $!\n"; - } - - if ($rcvd eq $sent) { - test 150, tainted $rcvd; - } else { - print "ok 150 # Skipped: SysV shared memory operation failed\n"; - } - } else { - print "ok 150 # Skipped: SysV shared memory is not available\n"; - } -} - -# test msgrcv -{ - unless ($ipcsysv) { - print "ok 151 # skipped: no IPC::SysV\n"; - last; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { - no strict 'subs'; - my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); - - my $sent = "message"; - my $type_sent = 1234; - my $rcvd; - my $type_rcvd; - - if (defined $id) { - if (msgsnd($id, pack("l! a*", $type_sent, $sent), 0)) { - if (msgrcv($id, $rcvd, 60, 0, 0)) { - ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); - } else { - warn "# msgrcv failed\n"; - } - } else { - warn "# msgsnd failed\n"; - } - msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; - } else { - warn "# msgget failed\n"; - } - - if ($rcvd eq $sent && $type_sent == $type_rcvd) { - test 151, tainted $rcvd; - } else { - print "ok 151 # Skipped: SysV message queue operation failed\n"; - } - } else { - print "ok 151 # Skipped: SysV message queues are not available\n"; - } -} - -{ - # bug id 20001004.006 - - open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; - local $/; - my $a = <IN>; - my $b = <IN>; - print "not " unless tainted($a) && tainted($b) && !defined($b); - print "ok 152\n"; - close IN; -} - -{ - # bug id 20001004.007 - - open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; - my $a = <IN>; - - my $c = { a => 42, - b => $a }; - print "not " unless !tainted($c->{a}) && tainted($c->{b}); - print "ok 153\n"; - - my $d = { a => $a, - b => 42 }; - print "not " unless tainted($d->{a}) && !tainted($d->{b}); - print "ok 154\n"; - - my $e = { a => 42, - b => { c => $a, d => 42 } }; - print "not " unless !tainted($e->{a}) && - !tainted($e->{b}) && - tainted($e->{b}->{c}) && - !tainted($e->{b}->{d}); - print "ok 155\n"; - - close IN; -} - diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t deleted file mode 100755 index cbf92c6..0000000 --- a/contrib/perl5/t/op/tie.t +++ /dev/null @@ -1,187 +0,0 @@ -#!./perl - -# This test harness will (eventually) test the "tie" functionality -# without the need for a *DBM* implementation. - -# Currently it only tests the untie warning - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -$|=1; - -# catch warnings into fatal errors -$SIG{__WARN__} = sub { die "WARNING: @_" } ; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -for (@prgs){ - my($prog,$expected) = split(/\nEXPECT\n/, $_); - eval "$prog" ; - $status = $?; - $results = $@ ; - $results =~ s/\n+$//; - $expected =~ s/\n+$//; - if ( $status or $results and $results !~ /^WARNING: $expected/){ - print STDERR "STATUS: $status\n"; - print STDERR "PROG: $prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ - -# standard behaviour, without any extra references -use Tie::Hash ; -tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# standard behaviour, without any extra references -use Tie::Hash ; -{package Tie::HashUntie; - use base 'Tie::StdHash'; - sub UNTIE - { - warn "Untied\n"; - } -} -tie %h, Tie::HashUntie; -untie %h; -EXPECT -Untied -######## - -# standard behaviour, with 1 extra reference -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference via tied -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference which is destroyed -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$a = 0 ; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference via tied which is destroyed -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict behaviour, without any extra references -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# strict behaviour, with 1 extra references generating an error -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -untie %h; -EXPECT -untie attempted while 1 inner references still exist -######## - -# strict behaviour, with 1 extra references via tied generating an error -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -untie %h; -EXPECT -untie attempted while 1 inner references still exist -######## - -# strict behaviour, with 1 extra references which are destroyed -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict behaviour, with extra 1 references via tied which are destroyed -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict error behaviour, with 2 extra references -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$b = tied %h ; -untie %h; -EXPECT -untie attempted while 2 inner references still exist -######## - -# strict behaviour, check scope of strictness. -no warnings 'untie'; -use Tie::Hash ; -$A = tie %H, Tie::StdHash; -$C = $B = tied %H ; -{ - use warnings 'untie'; - 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/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t deleted file mode 100755 index 8e78b2f..0000000 --- a/contrib/perl5/t/op/tiearray.t +++ /dev/null @@ -1,210 +0,0 @@ -#!./perl - - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my %seen; - -package Implement; - -sub TIEARRAY -{ - $seen{'TIEARRAY'}++; - my ($class,@val) = @_; - return bless \@val,$class; -} - -sub STORESIZE -{ - $seen{'STORESIZE'}++; - my ($ob,$sz) = @_; - return $#{$ob} = $sz-1; -} - -sub EXTEND -{ - $seen{'EXTEND'}++; - my ($ob,$sz) = @_; - return @$ob = $sz; -} - -sub FETCHSIZE -{ - $seen{'FETCHSIZE'}++; - return scalar(@{$_[0]}); -} - -sub FETCH -{ - $seen{'FETCH'}++; - my ($ob,$id) = @_; - return $ob->[$id]; -} - -sub STORE -{ - $seen{'STORE'}++; - my ($ob,$id,$val) = @_; - $ob->[$id] = $val; -} - -sub UNSHIFT -{ - $seen{'UNSHIFT'}++; - my $ob = shift; - unshift(@$ob,@_); -} - -sub PUSH -{ - $seen{'PUSH'}++; - my $ob = shift;; - push(@$ob,@_); -} - -sub CLEAR -{ - $seen{'CLEAR'}++; - @{$_[0]} = (); -} - -sub DESTROY -{ - $seen{'DESTROY'}++; -} - -sub POP -{ - $seen{'POP'}++; - my ($ob) = @_; - return pop(@$ob); -} - -sub SHIFT -{ - $seen{'SHIFT'}++; - my ($ob) = @_; - return shift(@$ob); -} - -sub SPLICE -{ - $seen{'SPLICE'}++; - my $ob = shift; - my $off = @_ ? shift : 0; - my $len = @_ ? shift : @$ob-1; - return splice(@$ob,$off,$len,@_); -} - -package main; - -print "1..31\n"; -my $test = 1; - -{my @ary; - -{ my $ob = tie @ary,'Implement',3,2,1; - print "not " unless $ob; - print "ok ", $test++,"\n"; - print "not " unless tied(@ary) == $ob; - print "ok ", $test++,"\n"; -} - - -print "not " unless @ary == 3; -print "ok ", $test++,"\n"; - -print "not " unless $#ary == 2; -print "ok ", $test++,"\n"; - -print "not " unless join(':',@ary) eq '3:2:1'; -print "ok ", $test++,"\n"; - -print "not " unless $seen{'FETCH'} >= 3; -print "ok ", $test++,"\n"; - -@ary = (1,2,3); - -print "not " unless $seen{'STORE'} >= 3; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '1:2:3'; -print "ok ", $test++,"\n"; - -{my @thing = @ary; -print "not " unless join(':',@thing) eq '1:2:3'; -print "ok ", $test++,"\n"; - -tie @thing,'Implement'; -@thing = @ary; -print "not " unless join(':',@thing) eq '1:2:3'; -print "ok ", $test++,"\n"; -} - -print "not " unless pop(@ary) == 3; -print "ok ", $test++,"\n"; -print "not " unless $seen{'POP'} == 1; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '1:2'; -print "ok ", $test++,"\n"; - -push(@ary,4); -print "not " unless $seen{'PUSH'} == 1; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '1:2:4'; -print "ok ", $test++,"\n"; - -my @x = splice(@ary,1,1,7); - - -print "not " unless $seen{'SPLICE'} == 1; -print "ok ", $test++,"\n"; - -print "not " unless @x == 1; -print "ok ", $test++,"\n"; -print "not " unless $x[0] == 2; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '1:7:4'; -print "ok ", $test++,"\n"; - -print "not " unless shift(@ary) == 1; -print "ok ", $test++,"\n"; -print "not " unless $seen{'SHIFT'} == 1; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '7:4'; -print "ok ", $test++,"\n"; - -my $n = unshift(@ary,5,6); -print "not " unless $seen{'UNSHIFT'} == 1; -print "ok ", $test++,"\n"; -print "not " unless $n == 4; -print "ok ", $test++,"\n"; -print "not " unless join(':',@ary) eq '5:6:7:4'; -print "ok ", $test++,"\n"; - -@ary = split(/:/,'1:2:3'); -print "not " unless join(':',@ary) eq '1:2:3'; -print "ok ", $test++,"\n"; - -my $t = 0; -foreach $n (@ary) - { - print "not " unless $n == ++$t; - print "ok ", $test++,"\n"; - } - -@ary = qw(3 2 1); -print "not " unless join(':',@ary) eq '3:2:1'; -print "ok ", $test++,"\n"; - -untie @ary; - -} - -print "not " unless $seen{'DESTROY'} == 2; -print "ok ", $test++,"\n"; - - - diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t deleted file mode 100755 index b04bdb7..0000000 --- a/contrib/perl5/t/op/tiehandle.t +++ /dev/null @@ -1,167 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my @expect; -my $data = ""; -my @data = (); -my $test = 1; - -sub ok { print "not " unless shift; print "ok ",$test++,"\n"; } - -package Implement; - -BEGIN { *ok = \*main::ok } - -sub compare { - return unless @expect; - return ok(0) unless(@_ == @expect); - - my $i; - for($i = 0 ; $i < @_ ; $i++) { - next if $_[$i] eq $expect[$i]; - return ok(0); - } - - ok(1); -} - -sub TIEHANDLE { - compare(TIEHANDLE => @_); - my ($class,@val) = @_; - return bless \@val,$class; -} - -sub PRINT { - compare(PRINT => @_); - 1; -} - -sub PRINTF { - compare(PRINTF => @_); - 2; -} - -sub READLINE { - compare(READLINE => @_); - wantarray ? @data : shift @data; -} - -sub GETC { - compare(GETC => @_); - substr($data,0,1); -} - -sub READ { - compare(READ => @_); - substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); - 3; -} - -sub WRITE { - compare(WRITE => @_); - $data = substr($_[1],$_[3] || 0, $_[2]); - length($data); -} - -sub CLOSE { - compare(CLOSE => @_); - - 5; -} - -package main; - -use Symbol; - -print "1..33\n"; - -my $fh = gensym; - -@expect = (TIEHANDLE => 'Implement'); -my $ob = tie *$fh,'Implement'; -ok(ref($ob) eq 'Implement'); -ok(tied(*$fh) == $ob); - -@expect = (PRINT => $ob,"some","text"); -$r = print $fh @expect[2,3]; -ok($r == 1); - -@expect = (PRINTF => $ob,"%s","text"); -$r = printf $fh @expect[2,3]; -ok($r == 2); - -$text = (@data = ("the line\n"))[0]; -@expect = (READLINE => $ob); -$ln = <$fh>; -ok($ln eq $text); - -@expect = (); -@in = @data = qw(a line at a time); -@line = <$fh>; -@expect = @in; -Implement::compare(@line); - -@expect = (GETC => $ob); -$data = "abc"; -$ch = getc $fh; -ok($ch eq "a"); - -$buf = "xyz"; -@expect = (READ => $ob, $buf, 3); -$data = "abc"; -$r = read $fh,$buf,3; -ok($r == 3); -ok($buf eq "abc"); - - -$buf = "xyzasd"; -@expect = (READ => $ob, $buf, 3,3); -$data = "abc"; -$r = sysread $fh,$buf,3,3; -ok($r == 3); -ok($buf eq "xyzabc"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4,1); -$data = ""; -$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); - -# Does aliasing work with tied FHs? -*ALIAS = *$fh; -@expect = (PRINT => $ob,"some","text"); -$r = print ALIAS @expect[2,3]; -ok($r == 1); - -{ - use warnings; - # Special case of aliasing STDERR, which used - # to dump core when warnings were enabled - *STDERR = *$fh; - @expect = (PRINT => $ob,"some","text"); - $r = print STDERR @expect[2,3]; - ok($r == 1); -} diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t deleted file mode 100755 index caf2c14..0000000 --- a/contrib/perl5/t/op/time.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./perl - -# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ - -if ($does_gmtime = gmtime(time)) { print "1..6\n" } -else { print "1..3\n" } - -($beguser,$begsys) = times; - -$beg = time; - -while (($now = time) == $beg) { sleep 1 } - -if ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";} - -for ($i = 0; $i < 100000; $i++) { - ($nowuser, $nowsys) = times; - $i = 200000 if $nowuser > $beguser && ( $nowsys > $begsys || - (!$nowsys && !$begsys)); - last if time - $beg > 20; -} - -if ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";} - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); -($xsec,$foo) = localtime($now); -$localyday = $yday; - -if ($sec != $xsec && $mday && $year) - {print "ok 3\n";} -else - {print "not ok 3\n";} - -exit 0 unless $does_gmtime; - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); -($xsec,$foo) = localtime($now); - -if ($sec != $xsec && $mday && $year) - {print "ok 4\n";} -else - {print "not ok 4\n";} - -if (index(" :0:1:-1:364:365:-364:-365:",':' . ($localyday - $yday) . ':') > 0) - {print "ok 5\n";} -else - {print "not ok 5\n";} - -# This could be stricter. -if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/) - {print "ok 6\n";} -else - {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t deleted file mode 100755 index c7ba0d8..0000000 --- a/contrib/perl5/t/op/tr.t +++ /dev/null @@ -1,311 +0,0 @@ -# tr.t - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..54\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"; -} -# - -# make sure that tr cancels IOK and NOK -($x = 12) =~ tr/1/3/; -(my $y = 12) =~ tr/1/3/; -($f = 1.5) =~ tr/1/3/; -(my $g = 1.5) =~ tr/1/3/; -print "not " unless $x + $y + $f + $g == 71; -print "ok 5\n"; - -# make sure tr is harmless if not updating - see [ID 20000511.005] -$_ = 'fred'; -/([a-z]{2})/; -$1 =~ tr/A-Z//; -s/^(\s*)f/$1F/; -print "not " if $_ ne 'Fred'; -print "ok 6\n"; - -# check tr handles UTF8 correctly -($x = 256.65.258) =~ tr/a/b/; -print "not " if $x ne 256.65.258 or length $x != 3; -print "ok 7\n"; -$x =~ tr/A/B/; -if (ord("\t") == 9) { # ASCII - print "not " if $x ne 256.66.258 or length $x != 3; -} -else { - print "not " if $x ne 256.65.258 or length $x != 3; -} -print "ok 8\n"; -# EBCDIC variants of the above tests -($x = 256.193.258) =~ tr/a/b/; -print "not " if $x ne 256.193.258 or length $x != 3; -print "ok 9\n"; -$x =~ tr/A/B/; -if (ord("\t") == 9) { # ASCII - print "not " if $x ne 256.193.258 or length $x != 3; -} -else { - print "not " if $x ne 256.194.258 or length $x != 3; -} -print "ok 10\n"; - -{ -if (ord("\t") == 9) { # ASCII - use utf8; -} -# 11 - changing UTF8 characters in a UTF8 string, same length. -$l = chr(300); $r = chr(400); -$x = 200.300.400; -$x =~ tr/\x{12c}/\x{190}/; -printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; -print "ok 11\n"; - -# 12 - changing UTF8 characters in UTF8 string, more bytes. -$x = 200.300.400; -$x =~ tr/\x{12c}/\x{be8}/; -printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; -print "ok 12\n"; - -# 13 - introducing UTF8 characters to non-UTF8 string. -$x = 100.125.60; -$x =~ tr/\x{64}/\x{190}/; -printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; -print "ok 13\n"; - -# 14 - removing UTF8 characters from UTF8 string -$x = 400.125.60; -$x =~ tr/\x{190}/\x{64}/; -printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; -print "ok 14\n"; - -# 15 - counting UTF8 chars in UTF8 string -$x = 400.125.60.400; -$y = $x =~ tr/\x{190}/\x{190}/; -print "not " if $y != 2; -print "ok 15\n"; - -# 16 - counting non-UTF8 chars in UTF8 string -$x = 60.400.125.60.400; -$y = $x =~ tr/\x{3c}/\x{3c}/; -print "not " if $y != 2; -print "ok 16\n"; - -# 17 - counting UTF8 chars in non-UTF8 string -$x = 200.125.60; -$y = $x =~ tr/\x{190}/\x{190}/; -print "not " if $y != 0; -print "ok 17\n"; -} - -# 18: test brokenness with tr/a-z-9//; -$_ = "abcdefghijklmnopqrstuvwxyz"; -eval "tr/a-z-9/ /"; -print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) - ? '' : 'not ', "ok 18\n"); - -# 19-21: Make sure leading and trailing hyphens still work -$_ = "car-rot9"; -tr/-a-m/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); - -$_ = "car-rot9"; -tr/a-m-/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n"); - -$_ = "car-rot9"; -tr/-a-m-/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n"); - -$_ = "abcdefghijklmnop"; -tr/ae-hn/./; -print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n"); - -$_ = "abcdefghijklmnop"; -tr/a-cf-kn-p/./; -print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n"); - -$_ = "abcdefghijklmnop"; -tr/a-ceg-ikm-o/./; -print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n"); - -# 25: Test reversed range check -# 20000705 MJD -eval "tr/m-d/ /"; -print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) - ? '' : 'not ', "ok 25\n"); - -# 26: test cannot update if read-only -eval '$1 =~ tr/x/y/'; -print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', - "ok 26\n"); - -# 27: test can count read-only -'abcdef' =~ /(bcd)/; -print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n"); - -# 28: test lhs OK if not updating -print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n"); - -# 29: test lhs bad if updating -eval '"123" =~ tr/1/1/'; -print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) - ? '' : 'not ', "ok 29\n"); - -# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) -# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) - -# Transliterate a byte to a byte, all four ways. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 30\n"; - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 31\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 32\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 33\n"; - -# Transliterate a byte to a wide character. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; -print "not " unless $a eq v300.301.172.300.301.172; -print "ok 34\n"; - -# Transliterate a wide character to a byte. - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; -print "not " unless $a eq v195.196.172.195.196.172; -print "ok 35\n"; - -# Transliterate a wide character to a wide character. - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; -print "not " unless $a eq v301.196.172.301.196.172; -print "ok 36\n"; - -# Transliterate both ways. - -($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; -print "not " unless $a eq v195.301.172.195.301.172; -print "ok 37\n"; - -# Transliterate all (four) ways. - -($a = v300.196.172.300.196.172.400.198.144) =~ - tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; -print "not " unless $a eq v197.301.173.197.301.173.401.198.144; -print "ok 38\n"; - -# Transliterate and count. - -print "not " - unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2; -print "ok 39\n"; - -print "not " - unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2; -print "ok 40\n"; - -# Transliterate with complement. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; -print "not " unless $a eq v301.196.301.301.196.301; -print "ok 41\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; -print "not " unless $a eq v300.197.197.300.197.197; -print "ok 42\n"; - -# Transliterate with deletion. - -($a = v300.196.172.300.196.172) =~ tr/\xc4//d; -print "not " unless $a eq v300.172.300.172; -print "ok 43\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; -print "not " unless $a eq v196.172.196.172; -print "ok 44\n"; - -# Transliterate with squeeze. - -($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; -print "not " unless $a eq v197.172.300.300.197.172; -print "ok 45\n"; - -($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; -print "not " unless $a eq v196.172.301.196.172.172; -print "ok 46\n"; - -# Tricky cases by Simon Cozens. - -($a = v196.172.200) =~ tr/\x{12c}/a/; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 47\n"; - -($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 48\n"; - -($a = v196.172.200) =~ tr/\x{12c}//d; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 49\n"; - -# UTF8 range - -($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; -print "not " unless $a eq v192.196.172.194.197.172; -print "ok 50\n"; - -($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; -print "not " unless $a eq v300.300.172.302.301.172; -print "ok 51\n"; - -# misc -($a = "R0_001") =~ tr/R_//d; -print "not " if hex($a) != 1; -print "ok 52\n"; - -@a = (1,2); map { y/1/./ for $_ } @a; -print "not " if "@a" ne ". 2"; -print "ok 53\n"; - -@a = (1,2); map { y/1/./ for $_.'' } @a; -print "not " if "@a" ne "1 2"; -print "ok 54\n"; diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t deleted file mode 100755 index f6e36a5..0000000 --- a/contrib/perl5/t/op/undef.t +++ /dev/null @@ -1,81 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..27\n"; - -print defined($a) ? "not ok 1\n" : "ok 1\n"; - -$a = 1+1; -print defined($a) ? "ok 2\n" : "not ok 2\n"; - -undef $a; -print defined($a) ? "not ok 3\n" : "ok 3\n"; - -$a = "hi"; -print defined($a) ? "ok 4\n" : "not ok 4\n"; - -$a = $b; -print defined($a) ? "not ok 5\n" : "ok 5\n"; - -@ary = ("1arg"); -$a = pop(@ary); -print defined($a) ? "ok 6\n" : "not ok 6\n"; -$a = pop(@ary); -print defined($a) ? "not ok 7\n" : "ok 7\n"; - -@ary = ("1arg"); -$a = shift(@ary); -print defined($a) ? "ok 8\n" : "not ok 8\n"; -$a = shift(@ary); -print defined($a) ? "not ok 9\n" : "ok 9\n"; - -$ary{'foo'} = 'hi'; -print defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n"; -print defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n"; -undef $ary{'foo'}; -print defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n"; - -print defined(@ary) ? "ok 13\n" : "not ok 13\n"; -print defined(%ary) ? "ok 14\n" : "not ok 14\n"; -undef @ary; -print defined(@ary) ? "not ok 15\n" : "ok 15\n"; -undef %ary; -print defined(%ary) ? "not ok 16\n" : "ok 16\n"; -@ary = (1); -print defined @ary ? "ok 17\n" : "not ok 17\n"; -%ary = (1,1); -print defined %ary ? "ok 18\n" : "not ok 18\n"; - -sub foo { print "ok 19\n"; } - -&foo || print "not 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/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t deleted file mode 100755 index e6db8e6..0000000 --- a/contrib/perl5/t/op/universal.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl -# -# check UNIVERSAL -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $| = 1; -} - -print "1..80\n"; - -$a = {}; -bless $a, "Bob"; -print "not " unless $a->isa("Bob"); -print "ok 1\n"; - -package Human; -sub eat {} - -package Female; -@ISA=qw(Human); - -package Alice; -@ISA=qw(Bob Female); -sub drink {} -sub new { bless {} } - -$Alice::VERSION = 2.718; - -{ - package Cedric; - our @ISA; - use base qw(Human); -} - -{ - package Programmer; - our $VERSION = 1.667; - - sub write_perl { 1 } -} - -package main; - -my $i = 2; -sub test { print "not " unless shift; print "ok $i\n"; $i++; } - -$a = new Alice; - -test $a->isa("Alice"); - -test $a->isa("Bob"); - -test $a->isa("Female"); - -test $a->isa("Human"); - -test ! $a->isa("Male"); - -test ! $a->isa('Programmer'); - -test $a->can("drink"); - -test $a->can("eat"); - -test ! $a->can("sleep"); - -test (!Cedric->isa('Programmer')); - -test (Cedric->isa('Human')); - -push(@Cedric::ISA,'Programmer'); - -test (Cedric->isa('Programmer')); - -{ - package Alice; - base::->import('Programmer'); -} - -test $a->isa('Programmer'); -test $a->isa("Female"); - -@Cedric::ISA = qw(Bob); - -test (!Cedric->isa('Programmer')); - -my $b = 'abc'; -my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); -my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); -for ($p=0; $p < @refs; $p++) { - for ($q=0; $q < @vals; $q++) { - test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); - }; -}; - -test ! UNIVERSAL::can(23, "can"); - -test $a->can("VERSION"); - -test $a->can("can"); -test ! $a->can("export_tags"); # a method in Exporter - -test (eval { $a->VERSION }) == 2.718; - -test ! (eval { $a->VERSION(2.719) }) && - $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; - -test (eval { $a->VERSION(2.718) }) && ! $@; - -my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -if ('a' lt 'A') { - test $subs eq "can isa VERSION"; -} else { - test $subs eq "VERSION can isa"; -} - -test $a->isa("UNIVERSAL"); - -# now use UNIVERSAL.pm and see what changes -eval "use UNIVERSAL"; - -test $a->isa("UNIVERSAL"); - -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -# XXX import being here is really a bug -if ('a' lt 'A') { - test $sub2 eq "can import isa VERSION"; -} else { - test $sub2 eq "VERSION can import isa"; -} - -eval 'sub UNIVERSAL::sleep {}'; -test $a->can("sleep"); - -test ! UNIVERSAL::can($b, "can"); - -test ! $a->can("export_tags"); # a method in Exporter - -test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); diff --git a/contrib/perl5/t/op/unshift.t b/contrib/perl5/t/op/unshift.t deleted file mode 100755 index 68d3775..0000000 --- a/contrib/perl5/t/op/unshift.t +++ /dev/null @@ -1,14 +0,0 @@ -#!./perl - -# $RCSfile: unshift.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:35 $ - -print "1..2\n"; - -@a = (1,2,3); -$cnt1 = unshift(a,0); - -if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";} -$cnt2 = unshift(a,3,2,1); -if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";} - - diff --git a/contrib/perl5/t/op/utf8decode.t b/contrib/perl5/t/op/utf8decode.t deleted file mode 100755 index 4d05a6b8..0000000 --- a/contrib/perl5/t/op/utf8decode.t +++ /dev/null @@ -1,183 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -no utf8; - -print "1..78\n"; - -my $test = 1; - -# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester, -# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt, -# version dated 2000-09-02. - -# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff -# because e.g. many patch programs have issues with binary data. - -my @MK = split(/\n/, <<__EOMK__); -1 Correct UTF-8 -1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" - 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5 -2 Boundary conditions -2.1 First possible sequence of certain length -2.1.1 y "\x00" 0 1 00 1 -2.1.2 y "\xc2\x80" 80 2 c2:80 1 -2.1.3 y "\xe0\xa0\x80" 800 3 e0:a0:80 1 -2.1.4 y "\xf0\x90\x80\x80" 10000 4 f0:90:80:80 1 -2.1.5 y "\xf8\x88\x80\x80\x80" 200000 5 f8:88:80:80:80 1 -2.1.6 y "\xfc\x84\x80\x80\x80\x80" 4000000 6 fc:84:80:80:80:80 1 -2.2 Last possible sequence of certain length -2.2.1 y "\x7f" 7f 1 7f 1 -2.2.2 y "\xdf\xbf" 7ff 2 df:bf 1 -# The ffff is illegal unless UTF8_ALLOW_FFFF -2.2.3 n "\xef\xbf\xbf" ffff 3 ef:bf:bf 1 character 0xffff -2.2.4 y "\xf7\xbf\xbf\xbf" 1fffff 4 f7:bf:bf:bf 1 -2.2.5 y "\xfb\xbf\xbf\xbf\xbf" 3ffffff 5 fb:bf:bf:bf:bf 1 -2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf" 7fffffff 6 fd:bf:bf:bf:bf:bf 1 -2.3 Other boundary conditions -2.3.1 y "\xed\x9f\xbf" d7ff 3 ed:9f:bf 1 -2.3.2 y "\xee\x80\x80" e000 3 ee:80:80 1 -2.3.3 y "\xef\xbf\xbd" fffd 3 ef:bf:bd 1 -2.3.4 y "\xf4\x8f\xbf\xbf" 10ffff 4 f4:8f:bf:bf 1 -2.3.5 y "\xf4\x90\x80\x80" 110000 4 f4:90:80:80 1 -3 Malformed sequences -3.1 Unexpected continuation bytes -3.1.1 n "\x80" - 1 80 - unexpected continuation byte 0x80 -3.1.2 n "\xbf" - 1 bf - unexpected continuation byte 0xbf -3.1.3 n "\x80\xbf" - 2 80:bf - unexpected continuation byte 0x80 -3.1.4 n "\x80\xbf\x80" - 3 80:bf:80 - unexpected continuation byte 0x80 -3.1.5 n "\x80\xbf\x80\xbf" - 4 80:bf:80:bf - unexpected continuation byte 0x80 -3.1.6 n "\x80\xbf\x80\xbf\x80" - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80 -3.1.7 n "\x80\xbf\x80\xbf\x80\xbf" - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80 -3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80 -3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf" - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80 -3.2 Lonely start characters -3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf " - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20 after start byte 0xc0 -3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef " - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20 after start byte 0xe0 -3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 " - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20 after start byte 0xf0 -3.2.4 n "\xf8 \xf9 \xfa \xfb " - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20 after start byte 0xf8 -3.2.5 n "\xfc \xfd " - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20 after start byte 0xfc -3.3 Sequences with last continuation byte missing -3.3.1 n "\xc0" - 1 c0 - 1 byte, need 2 -3.3.2 n "\xe0\x80" - 2 e0:80 - 2 bytes, need 3 -3.3.3 n "\xf0\x80\x80" - 3 f0:80:80 - 3 bytes, need 4 -3.3.4 n "\xf8\x80\x80\x80" - 4 f8:80:80:80 - 4 bytes, need 5 -3.3.5 n "\xfc\x80\x80\x80\x80" - 5 fc:80:80:80:80 - 5 bytes, need 6 -3.3.6 n "\xdf" - 1 df - 1 byte, need 2 -3.3.7 n "\xef\xbf" - 2 ef:bf - 2 bytes, need 3 -3.3.8 n "\xf7\xbf\xbf" - 3 f7:bf:bf - 3 bytes, need 4 -3.3.9 n "\xfb\xbf\xbf\xbf" - 4 fb:bf:bf:bf - 4 bytes, need 5 -3.3.10 n "\xfd\xbf\xbf\xbf\xbf" - 5 fd:bf:bf:bf:bf - 5 bytes, need 6 -3.4 Concatenation of incomplete sequences -3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf" - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0 after start byte 0xc0 -3.5 Impossible bytes -3.5.1 n "\xfe" - 1 fe - byte 0xfe -3.5.2 n "\xff" - 1 ff - byte 0xff -3.5.3 n "\xfe\xfe\xff\xff" - 4 fe:fe:ff:ff - byte 0xfe -4 Overlong sequences -4.1 Examples of an overlong ASCII character -4.1.1 n "\xc0\xaf" - 2 c0:af - 2 bytes, need 1 -4.1.2 n "\xe0\x80\xaf" - 3 e0:80:af - 3 bytes, need 1 -4.1.3 n "\xf0\x80\x80\xaf" - 4 f0:80:80:af - 4 bytes, need 1 -4.1.4 n "\xf8\x80\x80\x80\xaf" - 5 f8:80:80:80:af - 5 bytes, need 1 -4.1.5 n "\xfc\x80\x80\x80\x80\xaf" - 6 fc:80:80:80:80:af - 6 bytes, need 1 -4.2 Maximum overlong sequences -4.2.1 n "\xc1\xbf" - 2 c1:bf - 2 bytes, need 1 -4.2.2 n "\xe0\x9f\xbf" - 3 e0:9f:bf - 3 bytes, need 2 -4.2.3 n "\xf0\x8f\xbf\xbf" - 4 f0:8f:bf:bf - 4 bytes, need 3 -4.2.4 n "\xf8\x87\xbf\xbf\xbf" - 5 f8:87:bf:bf:bf - 5 bytes, need 4 -4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf" - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5 -4.3 Overlong representation of the NUL character -4.3.1 n "\xc0\x80" - 2 c0:80 - 2 bytes, need 1 -4.3.2 n "\xe0\x80\x80" - 3 e0:80:80 - 3 bytes, need 1 -4.3.3 n "\xf0\x80\x80\x80" - 4 f0:80:80:80 - 4 bytes, need 1 -4.3.4 n "\xf8\x80\x80\x80\x80" - 5 f8:80:80:80:80 - 5 bytes, need 1 -4.3.5 n "\xfc\x80\x80\x80\x80\x80" - 6 fc:80:80:80:80:80 - 6 bytes, need 1 -5 Illegal code positions -5.1 Single UTF-16 surrogates -5.1.1 n "\xed\xa0\x80" - 3 ed:a0:80 - UTF-16 surrogate 0xd800 -5.1.2 n "\xed\xad\xbf" - 3 ed:ad:bf - UTF-16 surrogate 0xdb7f -5.1.3 n "\xed\xae\x80" - 3 ed:ae:80 - UTF-16 surrogate 0xdb80 -5.1.4 n "\xed\xaf\xbf" - 3 ed:af:bf - UTF-16 surrogate 0xdbff -5.1.5 n "\xed\xb0\x80" - 3 ed:b0:80 - UTF-16 surrogate 0xdc00 -5.1.6 n "\xed\xbe\x80" - 3 ed:be:80 - UTF-16 surrogate 0xdf80 -5.1.7 n "\xed\xbf\xbf" - 3 ed:bf:bf - UTF-16 surrogate 0xdfff -5.2 Paired UTF-16 surrogates -5.2.1 n "\xed\xa0\x80\xed\xb0\x80" - 6 ed:a0:80:ed:b0:80 - UTF-16 surrogate 0xd800 -5.2.2 n "\xed\xa0\x80\xed\xbf\xbf" - 6 ed:a0:80:ed:bf:bf - UTF-16 surrogate 0xd800 -5.2.3 n "\xed\xad\xbf\xed\xb0\x80" - 6 ed:ad:bf:ed:b0:80 - UTF-16 surrogate 0xdb7f -5.2.4 n "\xed\xad\xbf\xed\xbf\xbf" - 6 ed:ad:bf:ed:bf:bf - UTF-16 surrogate 0xdb7f -5.2.5 n "\xed\xae\x80\xed\xb0\x80" - 6 ed:ae:80:ed:b0:80 - UTF-16 surrogate 0xdb80 -5.2.6 n "\xed\xae\x80\xed\xbf\xbf" - 6 ed:ae:80:ed:bf:bf - UTF-16 surrogate 0xdb80 -5.2.7 n "\xed\xaf\xbf\xed\xb0\x80" - 6 ed:af:bf:ed:b0:80 - UTF-16 surrogate 0xdbff -5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf" - 6 ed:af:bf:ed:bf:bf - UTF-16 surrogate 0xdbff -5.3 Other illegal code positions -5.3.1 n "\xef\xbf\xbe" - 3 ef:bf:be - byte order mark 0xfffe -# The ffff is illegal unless UTF8_ALLOW_FFFF -5.3.2 n "\xef\xbf\xbf" - 3 ef:bf:bf - character 0xffff -__EOMK__ - -# 104..181 -{ - my $WARNCNT; - my $id; - - local $SIG{__WARN__} = - sub { - print "# $id: @_"; - $WARNCNT++; - $WARNMSG = "@_"; - }; - - sub moan { - print "$id: @_"; - } - - sub test_unpack_U { - $WARNCNT = 0; - $WARNMSG = ""; - unpack('U*', $_[0]); - } - - for (@MK) { - if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) { - # print "# $_\n"; - } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) { - $id = $1; - my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) = - ($2, $3, $4, $5, $6, $7, $8); - my @hex = split(/:/, $hex); - unless (@hex == $byteslen) { - my $nhex = @hex; - moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n"; - } - { - use bytes; - my $bytesbyteslen = length($bytes); - unless ($bytesbyteslen == $byteslen) { - moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n"; - } - } - if ($okay eq 'y') { - test_unpack_U($bytes); - if ($WARNCNT) { - moan "unpack('U*') false negative\n"; - print "not "; - } - } elsif ($okay eq 'n') { - test_unpack_U($bytes); - if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) { - moan "unpack('U*') false positive\n"; - print "not "; - } - } - print "ok $test\n"; - $test++; - } else { - moan "unknown format\n"; - } - } -} diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t deleted file mode 100755 index 7fe0974..0000000 --- a/contrib/perl5/t/op/vec.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl - -print "1..30\n"; - -print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; -print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; -vec($foo,0,1) = 1; -print length($foo) == 1 ? "ok 3\n" : "not ok 3\n"; -print unpack('C',$foo) == 1 ? "ok 4\n" : "not ok 4\n"; -print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n"; - -print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n"; -vec($foo,20,1) = 1; -print vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n"; -print length($foo) == 3 ? "ok 8\n" : "not ok 8\n"; -print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n"; -vec($foo,1,8) = 0xf1; -print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; -print ((unpack('C',substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); -print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; -print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; -vec($Vec, 0, 32) = 0xbaddacab; -print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; -print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; - -# ensure vec() handles numericalness correctly -$foo = $bar = $baz = 0; -vec($foo = 0,0,1) = 1; -vec($bar = 0,1,1) = 1; -$baz = $foo | $bar; -print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; -print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; -print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; - -# error cases - -$x = eval { vec $foo, 0, 3 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 19\n"; -$x = eval { vec $foo, 0, 0 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 20\n"; -$x = eval { vec $foo, 0, -13 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 21\n"; -$x = eval { vec($foo, -1, 4) = 2 }; -print "not " if defined $x or $@ !~ /^Assigning to negative offset in vec/; -print "ok 22\n"; -print "not " if vec('abcd', 7, 8); -print "ok 23\n"; - -# UTF8 -# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling - -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -print "not " if vec($x, 0, 8) != 255; -print "ok 24\n"; -eval { vec($foo, 1, 8) }; -print "not " if $@; -print "ok 25\n"; -eval { vec($foo, 1, 8) = 13 }; -print "not " if $@; -print "ok 26\n"; -print "not " if $foo ne "\xc4\x0d\xc3\xbf\xc3\xbe"; -print "ok 27\n"; -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -vec($x, 2, 4) = 7; -print "not " if $x ne "\xff\xf7"; -print "ok 28\n"; - -# mixed magic - -$foo = "\x61\x62\x63\x64\x65\x66"; -print "not " if vec(substr($foo, 2, 2), 0, 16) != 25444; -print "ok 29\n"; -vec(substr($foo, 1,3), 5, 4) = 3; -print "not " if $foo ne "\x61\x62\x63\x34\x65\x66"; -print "ok 30\n"; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t deleted file mode 100755 index edfebd2..0000000 --- a/contrib/perl5/t/op/ver.t +++ /dev/null @@ -1,181 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..28\n"; - -my $test = 1; - -use v5.5.640; -require v5.5.640; -print "ok $test\n"; ++$test; - -# printing characters should work -if (ord("\t") == 9) { # ASCII - print v111; - print v107.32; - print "$test\n"; ++$test; - - # hash keys too - $h{v111.107} = "ok"; - print "$h{ok} $test\n"; ++$test; -} -else { # EBCDIC - print v150; - print v146.64; - print "$test\n"; ++$test; - - # hash keys too - $h{v150.146} = "ok"; - print "$h{ok} $test\n"; ++$test; -} - -# poetry optimization should also -sub v77 { "ok" } -$x = v77; -print "$x $test\n"; ++$test; - -# but not when dots are involved -if (ord("\t") == 9) { # ASCII - $x = v77.78.79; -} -else { - $x = v212.213.214; -} -print "not " unless $x eq "MNO"; -print "ok $test\n"; ++$test; - -print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; -print "ok $test\n"; ++$test; - -# -# now do the same without the "v" -use 5.5.640; -require 5.5.640; -print "ok $test\n"; ++$test; - -# hash keys too -if (ord("\t") == 9) { # ASCII - $h{111.107.32} = "ok"; -} -else { - $h{150.146.64} = "ok"; -} -print "$h{ok } $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - $x = 77.78.79; -} -else { - $x = 212.213.214; -} -print "not " unless $x eq "MNO"; -print "ok $test\n"; ++$test; - -print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; -print "ok $test\n"; ++$test; - -# test sprintf("%vd"...) etc -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; -} -else { - print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; -print "ok $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; -} -else { - print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; -print "ok $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; -} -else { - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%*vb", "##", v1.22.333.4444) - eq '1##10110##101001101##1000101011100'; -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vd", join("", map { chr } - unpack "U*", v2001.2002.2003)) - eq '2001.2002.2003'; -print "ok $test\n"; ++$test; - -{ - use bytes; - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; - } - else { - print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; - } - print "ok $test\n"; ++$test; - - print "not " unless - sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; - print "ok $test\n"; ++$test; - - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; - } - else { - print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; - } - print "ok $test\n"; ++$test; - - print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; - print "ok $test\n"; ++$test; - - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; - } - else { - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; - } - print "ok $test\n"; ++$test; - - print "not " unless sprintf("%*vb", "##", v1.22.333.4444) - eq '1##10110##11000101##10001101##11100001##10000101##10011100'; - print "ok $test\n"; ++$test; -} - -{ - # bug id 20000323.056 - - print "not " unless "\x{41}" eq +v65; - print "ok $test\n"; - $test++; - - print "not " unless "\x41" eq +v65; - print "ok $test\n"; - $test++; - - print "not " unless "\x{c8}" eq +v200; - print "ok $test\n"; - $test++; - - print "not " unless "\xc8" eq +v200; - print "ok $test\n"; - $test++; - - print "not " unless "\x{221b}" eq v8731; - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t deleted file mode 100755 index 4b6f37c..0000000 --- a/contrib/perl5/t/op/wantarray.t +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -print "1..7\n"; -sub context { - my ( $cona, $testnum ) = @_; - my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; - unless ( $cona eq $conb ) { - print "# Context $conb should be $cona\nnot "; - } - print "ok $testnum\n"; -} - -context('V',1); -$a = context('S',2); -@a = context('A',3); -scalar context('S',4); -$a = scalar context('S',5); -($a) = context('A',6); -($a) = scalar context('S',7); -1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t deleted file mode 100755 index 5b01eb7..0000000 --- a/contrib/perl5/t/op/write.t +++ /dev/null @@ -1,220 +0,0 @@ -#!./perl - -print "1..9\n"; - -my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; - -format OUT = -the quick brown @<< -$fox -jumped -@* -$multiline -^<<<<<<<<< -$foo -^<<<<<<<<< -$foo -^<<<<<<... -$foo -now @<<the@>>>> for all@|||||men to come @<<<< -{ - 'i' . 's', "time\n", $good, 'to' -} -. - -open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -$fox = 'foxiness'; -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT); -close OUT; - -$right = -"the quick brown fox -jumped -forescore -and -seven years -when in -the course -of huma... -now is the time for all good men to come to\n"; - -if (`$CAT Op_write.tmp` eq $right) - { print "ok 1\n"; unlink 'Op_write.tmp'; } -else - { print "not ok 1\n"; } - -$fox = 'wolfishness'; -my $fox = 'foxiness'; # Test a lexical variable. - -format OUT2 = -the quick brown @<< -$fox -jumped -@* -$multiline -^<<<<<<<<< ~~ -$foo -now @<<the@>>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' -. - -open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; - -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT2); -close OUT2; - -$right = -"the quick brown fox -jumped -forescore -and -seven years -when in -the course -of human -events it -becomes -necessary -now is the time for all good men to come to\n"; - -if (`$CAT Op_write.tmp` eq $right) - { print "ok 2\n"; unlink 'Op_write.tmp'; } -else - { print "not ok 2\n"; } - -eval <<'EOFORMAT'; -format OUT2 = -the brown quick @<< -$fox -jumped -@* -$multiline -and -^<<<<<<<<< ~~ -$foo -now @<<the@>>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' -. -EOFORMAT - -open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -$fox = 'foxiness'; -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT2); -close OUT2; - -$right = -"the brown quick fox -jumped -forescore -and -seven years -and -when in -the course -of human -events it -becomes -necessary -now is the time for all good men to come to\n"; - -if (`$CAT Op_write.tmp` eq $right) - { print "ok 3\n"; unlink 'Op_write.tmp'; } -else - { print "not ok 3\n"; } - -# formline tests - -$mustbe = <<EOT; -@ a -@> ab -@>> abc -@>>> abc -@>>>> abc -@>>>>> abc -@>>>>>> abc -@>>>>>>> abc -@>>>>>>>> abc -@>>>>>>>>> abc -@>>>>>>>>>> abc -EOT - -$was1 = $was2 = ''; -for (0..10) { - # lexical picture - $^A = ''; - my $format1 = '@' . '>' x $_; - formline $format1, 'abc'; - $was1 .= "$format1 $^A\n"; - # global - $^A = ''; - local $format2 = '@' . '>' x $_; - formline $format2, 'abc'; - $was2 .= "$format2 $^A\n"; -} -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"; } - -# test lexicals and globals -{ - my $this = "ok"; - our $that = 7; - format LEX = -@<<@| -$this,$that -. - open(LEX, ">&STDOUT") or die; - write LEX; - $that = 8; - write LEX; - close LEX; -} -# LEX_INTERPNORMAL test -my %e = ( a => 1 ); -format OUT4 = -@<<<<<< -"$e{a}" -. -open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; -write (OUT4); -close OUT4; -if (`$CAT Op_write.tmp` eq "1\n") { - print "ok 9\n"; - unlink "Op_write.tmp"; - } -else { - print "not ok 9\n"; - } diff --git a/contrib/perl5/t/pod/emptycmd.t b/contrib/perl5/t/pod/emptycmd.t deleted file mode 100755 index 815eba2..0000000 --- a/contrib/perl5/t/pod/emptycmd.t +++ /dev/null @@ -1,21 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - -__END__ - -=pod - -= this is a test -of the emergency -broadcast system - -=cut diff --git a/contrib/perl5/t/pod/emptycmd.xr b/contrib/perl5/t/pod/emptycmd.xr deleted file mode 100644 index f06d2db..0000000 --- a/contrib/perl5/t/pod/emptycmd.xr +++ /dev/null @@ -1,2 +0,0 @@ - = this is a test of the emergency broadcast system - diff --git a/contrib/perl5/t/pod/find.t b/contrib/perl5/t/pod/find.t deleted file mode 100755 index db39508..0000000 --- a/contrib/perl5/t/pod/find.t +++ /dev/null @@ -1,119 +0,0 @@ -# Testing of Pod::Find -# Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de> - -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; -} - -$| = 1; - -use Test; - -BEGIN { plan tests => 4 } - -use Pod::Find qw(pod_find pod_where); -use File::Spec; - -# load successful -ok(1); - -require Cwd; -my $THISDIR = Cwd::cwd(); -my $VERBOSE = 0; -my $lib_dir = File::Spec->catdir($THISDIR,'..','lib','Pod'); -if ($^O eq 'VMS') { - $lib_dir = VMS::Filespec::unixify(File::Spec->catdir($THISDIR,'-','lib','pod')); - $Qlib_dir = $lib_dir; - $Qlib_dir =~ s#\/#::#g; -} -print "### searching $lib_dir\n"; -my %pods = pod_find("$lib_dir"); -my $result = join(",", sort values %pods); -print "### found $result\n"; -my $compare = join(',', qw( - Checker - Find - Html - InputObjects - LaTeX - Man - ParseUtils - Parser - Plainer - Select - Text - Text::Color - Text::Overstrike - Text::Termcap - Usage -)); -if ($^O eq 'VMS') { - $compare = lc($compare); - $result = join(',', sort grep(/pod::/, values %pods)); - my $undollared = $Qlib_dir; - $undollared =~ s/\$/\\\$/g; - $undollared =~ s/\-/\\\-/g; - $result =~ s/$undollared/pod::/g; - my $count = 0; - my @result = split(/,/,$result); - my @compare = split(/,/,$compare); - foreach(@compare) { - $count += grep {/$_/} @result; - } - ok($count/($#result+1)-1,$#compare); -} -else { - ok($result,$compare); -} - -# File::Find is located in this place since eons -# and on all platforms, hopefully - -print "### searching for File::Find\n"; -$result = pod_where({ -inc => 1, -verbose => $VERBOSE }, 'File::Find') - || 'undef - pod not found!'; -print "### found $result\n"; - -if ($^O eq 'VMS') { # privlib is perl_root:[lib] OK but not under mms - $compare = "lib.File]Find.pm"; - $result =~ s/perl_root:\[\-?\.?//i; - $result =~ s/\[\-?\.?//i; # needed under `mms test` - ok($result,$compare); -} -else { - $compare = File::Spec->catfile("..","lib","File","Find.pm"); - ok(_canon($result),_canon($compare)); -} - -# Search for a documentation pod rather than a module -print "### searching for perlfunc.pod\n"; -$result = pod_where({ -dirs => ['../pod'], -verbose => $VERBOSE }, 'perlfunc') - || 'undef - perlfunc.pod not found!'; -print "### found $result\n"; - -if ($^O eq 'VMS') { # privlib is perl_root:[lib] unfortunately - $compare = "/lib/pod/perlfunc.pod"; - $result = VMS::Filespec::unixify($result); - $result =~ s/perl_root\///i; - $result =~ s/^\.\.//; # needed under `mms test` - ok($result,$compare); -} -else { - $compare = File::Spec->catfile("..","pod","perlfunc.pod"); - ok(_canon($result),_canon($compare)); -} - -# make the path as generic as possible -sub _canon -{ - my ($path) = @_; - $path = File::Spec->canonpath($path); - my @comp = File::Spec->splitpath($path); - my @dir = File::Spec->splitdir($comp[1]); - $comp[1] = File::Spec->catdir(@dir); - $path = File::Spec->catpath(@dir); - $path = uc($path) if File::Spec->case_tolerant; - $path; -} - diff --git a/contrib/perl5/t/pod/for.t b/contrib/perl5/t/pod/for.t deleted file mode 100755 index 4af528a..0000000 --- a/contrib/perl5/t/pod/for.t +++ /dev/null @@ -1,59 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This is a test - -=for theloveofpete -You shouldn't see this -or this -or this - -=for text -pod2text should see this -and this -and this - -and everything should see this! - -=begin text - -Similarly, this line ... - -and this one ... - -as well this one, - -should all be in pod2text output - -=end text - -Tweedley-deedley-dee, Im as happy as can be! -Tweedley-deedley-dum, cuz youre my honey sugar plum! - -=begin atthebeginning - -But I expect to see neither hide ... - -nor tail ... - -of this text - -=end atthebeginning - -The rest of this should show up in everything. - diff --git a/contrib/perl5/t/pod/for.xr b/contrib/perl5/t/pod/for.xr deleted file mode 100644 index 5f6b8b2..0000000 --- a/contrib/perl5/t/pod/for.xr +++ /dev/null @@ -1,21 +0,0 @@ - This is a test - - pod2text should see this - and this - and this - - and everything should see this! - -Similarly, this line ... - -and this one ... - -as well this one, - -should all be in pod2text output - - Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz - youre my honey sugar plum! - - The rest of this should show up in everything. - diff --git a/contrib/perl5/t/pod/headings.t b/contrib/perl5/t/pod/headings.t deleted file mode 100755 index 365aa7d..0000000 --- a/contrib/perl5/t/pod/headings.t +++ /dev/null @@ -1,140 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -################################################################# - use Pod::Usage; - pod2usage( VERBOSE => 2, EXIT => 1 ); - -=pod - -=head1 NAME - -B<rdb2pg> - insert an rdb table into a PostgreSQL database - -=head1 SYNOPSIS - -B<rdb2pg> [I<param>=I<value> ...] - -=head1 PARAMETERS - -B<rdb2pg> uses an IRAF-compatible parameter interface. -A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. - -=over 4 - -=item B<input> I<file> - -The B<RDB> file to insert into the database. If the given name -is the string C<stdin>, it reads from the UNIX standard input stream. - - -=back - -=head1 DESCRIPTION - -B<rdb2pg> will enter the data from an B<RDB> database into a -PostgreSQL database table, optionally creating the database and the -table if they do not exist. It automatically determines the -PostgreSQL data type from the column definition in the B<RDB> file, -but may be overriden via a series of definition files or directly -via one of its parameters. - -The target database and table are specified by the C<db> and C<table> -parameters. If they do not exist, and the C<createdb> parameter is -set, they will be created. Table field definitions are determined -in the following order: - -=cut - -################################################################# - -results in: - - -################################################################# - - rdb2pg - insert an rdb table into a PostgreSQL database - - rdb2pg [*param*=*value* ...] - - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - The RDB file to insert into the database. If the given name is - the string `stdin', it reads from the UNIX standard input - stream. - - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. - - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: - - -################################################################# - -while the original version of Text (using pod2text) gives - -################################################################# - -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template - parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name - is the string `stdin', it reads from the UNIX standard input - stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a - PostgreSQL database table, optionally creating the database and - the table if they do not exist. It automatically determines the - PostgreSQL data type from the column definition in the RDB file, - but may be overriden via a series of definition files or - directly via one of its parameters. - - The target database and table are specified by the `db' and - `table' parameters. If they do not exist, and the `createdb' - parameter is set, they will be created. Table field definitions - are determined in the following order: - - -################################################################# - - -Thanks for any help. If, as your email indicates, you've not much -time to look at this, I can work around things by calling pod2text() -directly using the official Text.pm. - -Diab - -------------- -Diab Jerius -djerius@cfa.harvard.edu - diff --git a/contrib/perl5/t/pod/headings.xr b/contrib/perl5/t/pod/headings.xr deleted file mode 100644 index fb37a2b..0000000 --- a/contrib/perl5/t/pod/headings.xr +++ /dev/null @@ -1,26 +0,0 @@ -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template parameter - file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name is the - string `stdin', it reads from the UNIX standard input stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a PostgreSQL - database table, optionally creating the database and the table if they - do not exist. It automatically determines the PostgreSQL data type from - the column definition in the RDB file, but may be overriden via a series - of definition files or directly via one of its parameters. - - The target database and table are specified by the `db' and `table' - parameters. If they do not exist, and the `createdb' parameter is set, - they will be created. Table field definitions are determined in the - following order: - diff --git a/contrib/perl5/t/pod/include.t b/contrib/perl5/t/pod/include.t deleted file mode 100755 index b6f1e31..0000000 --- a/contrib/perl5/t/pod/include.t +++ /dev/null @@ -1,36 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This file tries to demonstrate a simple =include directive -for pods. It is used as follows: - - =include filename - -where "filename" is expected to be an absolute pathname, or else -reside be relative to the directory in which the current processed -podfile resides, or be relative to the current directory. - -Lets try it out with the file "included.t" shall we. - -***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** - -=include included.t - -***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** - -So how did we do??? diff --git a/contrib/perl5/t/pod/include.xr b/contrib/perl5/t/pod/include.xr deleted file mode 100644 index 624ee44..0000000 --- a/contrib/perl5/t/pod/include.xr +++ /dev/null @@ -1,22 +0,0 @@ - This file tries to demonstrate a simple =include directive for pods. It - is used as follows: - - =include filename - - where "filename" is expected to be an absolute pathname, or else reside - be relative to the directory in which the current processed podfile - resides, or be relative to the current directory. - - Lets try it out with the file "included.t" shall we. - - ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE*** - -###### begin =include included.t ##### - This is the text of the included file named "included.t". It should - appear in the final pod document from pod2xxx - -###### end =include included.t ##### - ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE*** - - So how did we do??? - diff --git a/contrib/perl5/t/pod/included.t b/contrib/perl5/t/pod/included.t deleted file mode 100755 index a25b37b..0000000 --- a/contrib/perl5/t/pod/included.t +++ /dev/null @@ -1,35 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -##------------------------------------------------------------ -# This file is =included by "include.t" -# -# This text should NOT be in the resultant pod document -# because we havent seen an =xxx pod directive in this file! -##------------------------------------------------------------ - -=pod - -This is the text of the included file named "included.t". -It should appear in the final pod document from pod2xxx - -=cut - -##------------------------------------------------------------ -# This text should NOT be in the resultant pod document -# because it is *after* an =cut an no other pod directives -# proceed it! -##------------------------------------------------------------ diff --git a/contrib/perl5/t/pod/included.xr b/contrib/perl5/t/pod/included.xr deleted file mode 100644 index 54142fa..0000000 --- a/contrib/perl5/t/pod/included.xr +++ /dev/null @@ -1,3 +0,0 @@ - This is the text of the included file named "included.t". It should - appear in the final pod document from pod2xxx - diff --git a/contrib/perl5/t/pod/lref.t b/contrib/perl5/t/pod/lref.t deleted file mode 100755 index 1dd8c68..0000000 --- a/contrib/perl5/t/pod/lref.t +++ /dev/null @@ -1,66 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -Try out I<LOTS> of different ways of specifying references: - -Reference the L<manpage/section> - -Reference the L<manpage / section> - -Reference the L<manpage/ section> - -Reference the L<manpage /section> - -Reference the L<"manpage/section"> - -Reference the L<"manpage"/section> - -Reference the L<manpage/"section"> - -Reference the L<manpage/ -section> - -Reference the L<manpage -/section> - -Now try it using the new "|" stuff ... - -Reference the L<thistext|manpage/section> - -Reference the L<thistext | manpage / section> - -Reference the L<thistext| manpage/ section> - -Reference the L<thistext |manpage /section> - -Reference the L<thistext| -"manpage/section"> - -Reference the L<thistext -|"manpage"/section> - -Reference the L<thistext|manpage/"section"> - -Reference the L<thistext| -manpage/ -section> - -Reference the L<thistext -|manpage -/section> - diff --git a/contrib/perl5/t/pod/lref.xr b/contrib/perl5/t/pod/lref.xr deleted file mode 100644 index 297053b..0000000 --- a/contrib/perl5/t/pod/lref.xr +++ /dev/null @@ -1,40 +0,0 @@ - Try out *LOTS* of different ways of specifying references: - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section on "manpage/section" - - Reference the the section entry in the "manpage" manpage - - Reference the the section on "section" in the manpage manpage - - Reference the the section entry in the manpage manpage - - Reference the the section entry in the manpage manpage - - Now try it using the new "|" stuff ... - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - - Reference the thistext - diff --git a/contrib/perl5/t/pod/multiline_items.t b/contrib/perl5/t/pod/multiline_items.t deleted file mode 100755 index 334832d..0000000 --- a/contrib/perl5/t/pod/multiline_items.t +++ /dev/null @@ -1,31 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=head1 Test multiline item lists - -This is a test to ensure that multiline =item paragraphs -get indented appropriately. - -=over 4 - -=item This -is -a -test. - -=back - -=cut diff --git a/contrib/perl5/t/pod/multiline_items.xr b/contrib/perl5/t/pod/multiline_items.xr deleted file mode 100644 index dddf05f..0000000 --- a/contrib/perl5/t/pod/multiline_items.xr +++ /dev/null @@ -1,5 +0,0 @@ -Test multiline item lists - This is a test to ensure that multiline =item paragraphs get indented - appropriately. - - This is a test. diff --git a/contrib/perl5/t/pod/nested_items.t b/contrib/perl5/t/pod/nested_items.t deleted file mode 100755 index 0b86702..0000000 --- a/contrib/perl5/t/pod/nested_items.t +++ /dev/null @@ -1,64 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=head1 Test nested item lists - -This is a test to ensure the nested =item paragraphs -get indented appropriately. - -=over 2 - -=item 1 - -First section. - -=over 2 - -=item a - -this is item a - -=item b - -this is item b - -=back - -=item 2 - -Second section. - -=over 2 - -=item a - -this is item a - -=item b - -this is item b - -=item c - -=item d - -This is item c & d. - -=back - -=back - -=cut diff --git a/contrib/perl5/t/pod/nested_items.xr b/contrib/perl5/t/pod/nested_items.xr deleted file mode 100644 index dd1adac..0000000 --- a/contrib/perl5/t/pod/nested_items.xr +++ /dev/null @@ -1,19 +0,0 @@ -Test nested item lists - This is a test to ensure the nested =item paragraphs get indented - appropriately. - - 1 First section. - - a this is item a - - b this is item b - - 2 Second section. - - a this is item a - - b this is item b - - c - d This is item c & d. - diff --git a/contrib/perl5/t/pod/nested_seqs.t b/contrib/perl5/t/pod/nested_seqs.t deleted file mode 100755 index 9f30533..0000000 --- a/contrib/perl5/t/pod/nested_seqs.t +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -The statement: C<This is dog kind's I<finest> hour!> is a parody of a -quotation from Winston Churchill. - -=cut - diff --git a/contrib/perl5/t/pod/nested_seqs.xr b/contrib/perl5/t/pod/nested_seqs.xr deleted file mode 100644 index f981061..0000000 --- a/contrib/perl5/t/pod/nested_seqs.xr +++ /dev/null @@ -1,3 +0,0 @@ - The statement: `This is dog kind's *finest* hour!' is a parody of a - quotation from Winston Churchill. - diff --git a/contrib/perl5/t/pod/oneline_cmds.t b/contrib/perl5/t/pod/oneline_cmds.t deleted file mode 100755 index bba0e4a..0000000 --- a/contrib/perl5/t/pod/oneline_cmds.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -==head1 NAME -B<rdb2pg> - insert an rdb table into a PostgreSQL database - -==head1 SYNOPSIS -B<rdb2pg> [I<param>=I<value> ...] - -==head1 PARAMETERS -B<rdb2pg> uses an IRAF-compatible parameter interface. -A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>. - -==over 4 -==item B<input> I<file> -The B<RDB> file to insert into the database. If the given name -is the string C<stdin>, it reads from the UNIX standard input stream. - -==back - -==head1 DESCRIPTION -B<rdb2pg> will enter the data from an B<RDB> database into a -PostgreSQL database table, optionally creating the database and the -table if they do not exist. It automatically determines the -PostgreSQL data type from the column definition in the B<RDB> file, -but may be overriden via a series of definition files or directly -via one of its parameters. - -The target database and table are specified by the C<db> and C<table> -parameters. If they do not exist, and the C<createdb> parameter is -set, they will be created. Table field definitions are determined -in the following order: - diff --git a/contrib/perl5/t/pod/oneline_cmds.xr b/contrib/perl5/t/pod/oneline_cmds.xr deleted file mode 100644 index fb37a2b..0000000 --- a/contrib/perl5/t/pod/oneline_cmds.xr +++ /dev/null @@ -1,26 +0,0 @@ -NAME - rdb2pg - insert an rdb table into a PostgreSQL database - -SYNOPSIS - rdb2pg [*param*=*value* ...] - -PARAMETERS - rdb2pg uses an IRAF-compatible parameter interface. A template parameter - file is in /proj/axaf/simul/lib/uparm/rdb2pg.par. - - input *file* - The RDB file to insert into the database. If the given name is the - string `stdin', it reads from the UNIX standard input stream. - -DESCRIPTION - rdb2pg will enter the data from an RDB database into a PostgreSQL - database table, optionally creating the database and the table if they - do not exist. It automatically determines the PostgreSQL data type from - the column definition in the RDB file, but may be overriden via a series - of definition files or directly via one of its parameters. - - The target database and table are specified by the `db' and `table' - parameters. If they do not exist, and the `createdb' parameter is set, - they will be created. Table field definitions are determined in the - following order: - diff --git a/contrib/perl5/t/pod/pod2usage.t b/contrib/perl5/t/pod/pod2usage.t deleted file mode 100755 index 70cbacd..0000000 --- a/contrib/perl5/t/pod/pod2usage.t +++ /dev/null @@ -1,18 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - -=include pod2usage.PL - - diff --git a/contrib/perl5/t/pod/pod2usage.xr b/contrib/perl5/t/pod/pod2usage.xr deleted file mode 100644 index 7315d40..0000000 --- a/contrib/perl5/t/pod/pod2usage.xr +++ /dev/null @@ -1,55 +0,0 @@ -###### begin =include pod2usage.PL ##### -NAME - pod2usage - print usage messages from embedded pod docs in files - -SYNOPSIS - pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*] - [-verbose *level*] [-pathlist *dirlist*] *file* - -OPTIONS AND ARGUMENTS - -help Print a brief help message and exit. - - -man Print this command's manual page and exit. - - -exit *exitval* - The exit status value to return. - - -output *outfile* - The output file to print to. If the special names "-" or ">&1" - or ">&STDOUT" are used then standard output is used. If ">&2" or - ">&STDERR" is used then standard error is used. - - -verbose *level* - The desired level of verbosity to use: - - 1 : print SYNOPSIS only - 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections - 3 : print the entire manpage (similar to running pod2text) - - -pathlist *dirlist* - Specifies one or more directories to search for the input file - if it was not supplied with an absolute path. Each directory - path in the given list should be separated by a ':' on Unix (';' - on MSWin32 and DOS). - - *file* The pathname of a file containing pod documentation to be output - in usage mesage format (defaults to standard input). - -DESCRIPTION - pod2usage will read the given input file looking for pod documentation - and will print the corresponding usage message. If no input file is - specifed than standard input is read. - - pod2usage invokes the pod2usage() function in the Pod::Usage module. - Please see the pod2usage() entry in the Pod::Usage manpage. - -SEE ALSO - the Pod::Usage manpage, the pod2text(1) manpage - -AUTHOR - Brad Appleton <bradapp@enteract.com> - - Based on code for pod2text(1) written by Tom Christiansen - <tchrist@mox.perl.com> - -###### end =include pod2usage.PL ##### diff --git a/contrib/perl5/t/pod/poderrs.t b/contrib/perl5/t/pod/poderrs.t deleted file mode 100755 index 1b92ede..0000000 --- a/contrib/perl5/t/pod/poderrs.t +++ /dev/null @@ -1,198 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testpchk.pl"; - import TestPodChecker; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodchecker \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - -### Deliberately throw in some blank but non-empty lines - -### The above line should contain spaces - - -__END__ - - -=head1 NAME - -poderrors.t - test Pod::Checker on some pod syntax errors - -=unknown1 this is an unknown command with two N<unknownA> -and D<unknownB> interior sequences. - -This is some paragraph text with some unknown interior sequences, -such as Q<unknown2>, -A<unknown3>, -and Y<unknown4 V<unknown5>>. - -Now try some unterminated sequences like -I<hello mudda! -B<hello fadda! - -Here I am at C<camp granada! - -Camps is very, -entertaining. -And they say we'll have some fun if it stops raining! - -Okay, now use a non-empty blank line to terminate a paragraph and make -sure we get a warning. - -The above blank line contains tabs and spaces only - -=head1 Additional tests - -=head2 item without over - -=item oops - -=head2 back without over - -=back - -=head2 over without back - -=over 4 - -=item aaps - -=head2 end without begin - -=end - -=head2 begin and begin - -=begin html - -=begin text - -=end - -=end - -second one results in end w/o begin - -=head2 begin w/o formatter - -=begin - -=end - -=head2 for w/o formatter - -=for - -something... - -=head2 Nested sequences of the same type - -C<code I<italic C<code again!>>> - -=head2 Garbled entities - -E<alea iacta est> -E<C<auml>> -E<abcI<bla>> -E<0x100> -E<07777> -E<300> - -=head2 Unresolved internal links - -L</"begin or begin"> -L<"end with begin"> -L</OoPs> - -=head2 Some links with problems - -L<abc -def> -L<> -L< aha> -L<oho > -L<"Warnings"> this one is ok -L</unescaped> ok too, this POD has an X of the same name - -=head2 Warnings - -L<passwd(5)> -L<some text with / in it|perlvar/$|> should give warnings as hell - -=over 4 - -=item bla - -=back 200 - -the 200 is evil - -=begin html - -What? - -=end xml - -X<unescaped>see these unescaped < and > in the text? - -=head2 Misc - -Z<ddd> should be empty - -X<> should not be empty - -=over four - -This paragrapgh is misplaced - it ought to be an item. - -=item four should be numeric! - -=item - -=item blah - -=item previous is all empty!!! - -=back - -All empty over/back: - -=over 4 - -=back - -item w/o name - -=cut - -=pod bla - -bla is evil - -=cut blub - -blub is evil - -=head2 reoccurence - -=over 4 - -=item Misc - -we already have a head Misc - -=back - -=head2 some heading - -=head2 another one - -previous section is empty! - -=cut - - diff --git a/contrib/perl5/t/pod/poderrs.xr b/contrib/perl5/t/pod/poderrs.xr deleted file mode 100644 index a21efdb..0000000 --- a/contrib/perl5/t/pod/poderrs.xr +++ /dev/null @@ -1,46 +0,0 @@ -*** ERROR: Unknown command 'unknown1' at line 25 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Q' at line 29 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'A' at line 30 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'Y' at line 31 in file t/pod/poderrs.t -*** ERROR: Unknown interior-sequence 'V' at line 31 in file t/pod/poderrs.t -*** ERROR: unterminated B<...> at line 35 in file t/pod/poderrs.t -*** ERROR: unterminated I<...> at line 34 in file t/pod/poderrs.t -*** ERROR: unterminated C<...> at line 37 in file t/pod/poderrs.t -*** WARNING: line containing nothing but whitespace in paragraph at line 45 in file t/pod/poderrs.t -*** ERROR: =item without previous =over at line 52 in file t/pod/poderrs.t -*** ERROR: =back without previous =over at line 56 in file t/pod/poderrs.t -*** ERROR: =over on line 60 without closing =back (at head2) at line 64 in file t/pod/poderrs.t -*** ERROR: =end without =begin at line 66 in file t/pod/poderrs.t -*** ERROR: Nested =begin's (first at line 70:html) at line 72 in file t/pod/poderrs.t -*** ERROR: =end without =begin at line 76 in file t/pod/poderrs.t -*** ERROR: No argument for =begin at line 82 in file t/pod/poderrs.t -*** ERROR: =for without formatter specification at line 88 in file t/pod/poderrs.t -*** ERROR: nested commands C<...C<...>...> at line 94 in file t/pod/poderrs.t -*** ERROR: garbled entity E<alea iacta est> at line 98 in file t/pod/poderrs.t -*** ERROR: garbled entity E<C<auml>> at line 99 in file t/pod/poderrs.t -*** ERROR: garbled entity E<abcI<bla>> at line 100 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<0x100> at line 101 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<07777> at line 102 in file t/pod/poderrs.t -*** ERROR: Entity number out of range E<300> at line 103 in file t/pod/poderrs.t -*** ERROR: malformed link L<> : empty link at line 115 in file t/pod/poderrs.t -*** WARNING: ignoring leading whitespace in link at line 116 in file t/pod/poderrs.t -*** WARNING: ignoring trailing whitespace in link at line 117 in file t/pod/poderrs.t -*** WARNING: (section) in 'passwd(5)' deprecated at line 123 in file t/pod/poderrs.t -*** WARNING: node '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t -*** WARNING: alternative text '$|' contains non-escaped | or / at line 124 in file t/pod/poderrs.t -*** ERROR: Spurious character(s) after =back at line 130 in file t/pod/poderrs.t -*** ERROR: Nonempty Z<> at line 144 in file t/pod/poderrs.t -*** ERROR: Empty X<> at line 146 in file t/pod/poderrs.t -*** WARNING: preceding non-item paragraph(s) at line 152 in file t/pod/poderrs.t -*** WARNING: No argument for =item at line 154 in file t/pod/poderrs.t -*** WARNING: previous =item has no contents at line 156 in file t/pod/poderrs.t -*** WARNING: No items in =over (at line 164) / =back list at line 166 in file t/pod/poderrs.t -*** ERROR: Spurious text after =pod at line 172 in file t/pod/poderrs.t -*** ERROR: Spurious text after =cut at line 176 in file t/pod/poderrs.t -*** WARNING: empty section in previous paragraph at line 192 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'begin or begin' at line 107 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'end with begin' at line 108 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'OoPs' at line 109 in file t/pod/poderrs.t -*** ERROR: unresolved internal link 'abc def' at line 113 in file t/pod/poderrs.t -*** WARNING: multiple occurence of link target 'Misc' at line - in file t/pod/poderrs.t -t/pod/poderrs.t has 33 pod syntax errors. diff --git a/contrib/perl5/t/pod/podselect.t b/contrib/perl5/t/pod/podselect.t deleted file mode 100755 index 5d45cdb..0000000 --- a/contrib/perl5/t/pod/podselect.t +++ /dev/null @@ -1,18 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - -=include podselect.PL - - diff --git a/contrib/perl5/t/pod/podselect.xr b/contrib/perl5/t/pod/podselect.xr deleted file mode 100644 index 7d1188d..0000000 --- a/contrib/perl5/t/pod/podselect.xr +++ /dev/null @@ -1,42 +0,0 @@ -###### begin =include podselect.PL ##### -NAME - podselect - print selected sections of pod documentation on standard - output - -SYNOPSIS - podselect [-help] [-man] [-section *section-spec*] [*file* ...] - -OPTIONS AND ARGUMENTS - -help Print a brief help message and exit. - - -man Print the manual page and exit. - - -section *section-spec* - Specify a section to include in the output. See the section on - "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the - format to use for *section-spec*. This option may be given - multiple times on the command line. - - *file* The pathname of a file from which to select sections of pod - documentation (defaults to standard input). - -DESCRIPTION - podselect will read the given input files looking for pod documentation - and will print out (in raw pod format) all sections that match one ore - more of the given section specifications. If no section specifications - are given than all pod sections encountered are output. - - podselect invokes the podselect() function exported by Pod::Select - Please see the podselect() entry in the Pod::Select manpage for more - details. - -SEE ALSO - the Pod::Parser manpage and the Pod::Select manpage - -AUTHOR - Brad Appleton <bradapp@enteract.com> - - Based on code for Pod::Text::pod2text(1) written by Tom Christiansen - <tchrist@mox.perl.com> - -###### end =include podselect.PL ##### diff --git a/contrib/perl5/t/pod/special_seqs.t b/contrib/perl5/t/pod/special_seqs.t deleted file mode 100755 index c6b2ce1..0000000 --- a/contrib/perl5/t/pod/special_seqs.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - unshift @INC, './pod'; - require "testp2pt.pl"; - import TestPodIncPlainText; -} - -my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash -my $passed = testpodplaintext \%options, $0; -exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE}; - - -__END__ - - -=pod - -This is a test to see if I can do not only C<$self> and C<method()>, but -also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and -C<< $Foo <=> $Bar >> without resorting to escape sequences. If -I want to refer to the right-shift operator I can do something -like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>. - -Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>. -And I also want to make sure that newlines work like this -C<<< -$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b] ->>> - -Of course I should still be able to do all this I<with> escape sequences -too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and C<{FOO=E<gt>BAR}>. - -Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>. - -And make sure that C<0> works too! - -Now, if I use << or >> as my delimiters, then I have to use whitespace. -So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end -up doing what you might expect since the first > will still terminate -the first < seen. - -Lets make sure these work for empty ones too, like C<< >> and C<< >> >> -(just to be obnoxious) - -=cut diff --git a/contrib/perl5/t/pod/special_seqs.xr b/contrib/perl5/t/pod/special_seqs.xr deleted file mode 100644 index a8c715a..0000000 --- a/contrib/perl5/t/pod/special_seqs.xr +++ /dev/null @@ -1,25 +0,0 @@ - This is a test to see if I can do not only `$self' and `method()', but - also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar' - without resorting to escape sequences. If I want to refer to the - right-shift operator I can do something like `$x >> 3' or even `$y >> - 5'. - - Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'. - And I also want to make sure that newlines work like this - `$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]' - - Of course I should still be able to do all this *with* escape sequences - too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'. - - Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'. - - And make sure that `0' works too! - - Now, if I use << or >> as my delimiters, then I have to use whitespace. - So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end - up doing what you might expect since the first > will still terminate - the first < seen. - - Lets make sure these work for empty ones too, like and `>>' (just to be - obnoxious) - diff --git a/contrib/perl5/t/pod/testcmp.pl b/contrib/perl5/t/pod/testcmp.pl deleted file mode 100644 index 5f62171..0000000 --- a/contrib/perl5/t/pod/testcmp.pl +++ /dev/null @@ -1,91 +0,0 @@ -package TestCompare; - -use vars qw(@ISA @EXPORT $MYPKG); -#use strict; -#use diagnostics; -use Carp; -use Exporter; -use File::Basename; -use File::Spec; -use FileHandle; - -@ISA = qw(Exporter); -@EXPORT = qw(&testcmp); -$MYPKG = eval { (caller)[0] }; - -##-------------------------------------------------------------------------- - -=head1 NAME - -testcmp -- compare two files line-by-line - -=head1 SYNOPSIS - - $is_diff = testcmp($file1, $file2); - -or - - $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2); - -=head2 DESCRIPTION - -Compare two text files line-by-line and return 0 if they are the -same, 1 if they differ. Each of $file1 and $file2 may be a filenames, -or a filehandles (in which case it must already be open for reading). - -If the first argument is a hashref, then the B<-cmplines> key in the -hash may have a subroutine reference as its corresponding value. -The referenced user-defined subroutine should be a line-comparator -function that takes two pre-chomped text-lines as its arguments -(the first is from $file1 and the second is from $file2). It should -return 0 if it considers the two lines equivalent, and non-zero -otherwise. - -=cut - -##-------------------------------------------------------------------------- - -sub testcmp( $ $ ; $) { - my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : (); - my ($file1, $file2) = @_; - my ($fh1, $fh2) = ($file1, $file2); - unless (ref $fh1) { - $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!"; - } - unless (ref $fh2) { - $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!"; - } - - my $cmplines = $opts{'-cmplines'} || undef; - my ($f1text, $f2text) = ("", ""); - my ($line, $diffs) = (0, 0); - - while ( defined($f1text) and defined($f2text) ) { - defined($f1text = <$fh1>) and chomp($f1text); - defined($f2text = <$fh2>) and chomp($f2text); - ++$line; - last unless ( defined($f1text) and defined($f2text) ); - $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text) - : ($f1text ne $f2text); - last if $diffs; - } - close($fh1) unless (ref $file1); - close($fh2) unless (ref $file2); - - $diffs = 1 if (defined($f1text) or defined($f2text)); - if ( defined($f1text) and defined($f2text) ) { - ## these two lines must be different - warn "$file1 and $file2 differ at line $line\n"; - } - elsif (defined($f1text) and (! defined($f1text))) { - ## file1 must be shorter - warn "$file1 is shorter than $file2\n"; - } - elsif (defined $f2text) { - ## file2 must be longer - warn "$file1 is shorter than $file2\n"; - } - return $diffs; -} - -1; diff --git a/contrib/perl5/t/pod/testp2pt.pl b/contrib/perl5/t/pod/testp2pt.pl deleted file mode 100644 index 8cfdbb9..0000000 --- a/contrib/perl5/t/pod/testp2pt.pl +++ /dev/null @@ -1,196 +0,0 @@ -package TestPodIncPlainText; - -BEGIN { - use File::Basename; - use File::Spec; - use Cwd qw(abs_path); - push @INC, '..'; - my $THISDIR = abs_path(dirname $0); - unshift @INC, $THISDIR; - require "testcmp.pl"; - import TestCompare; - my $PARENTDIR = dirname $THISDIR; - push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); -} - -#use strict; -#use diagnostics; -use Carp; -use Exporter; -#use File::Compare; -#use Cwd qw(abs_path); - -use vars qw($MYPKG @EXPORT @ISA); -$MYPKG = eval { (caller)[0] }; -@EXPORT = qw(&testpodplaintext); -BEGIN { - if ( $] >= 5.005_58 ) { - require Pod::Text; - @ISA = qw( Pod::Text ); - } - else { - require Pod::PlainText; - @ISA = qw( Pod::PlainText ); - } - require VMS::Filespec if $^O eq 'VMS'; -} - -## Hardcode settings for TERMCAP and COLUMNS so we can try to get -## reproducible results between environments -@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); - -sub catfile(@) { File::Spec->catfile(@_); } - -my $INSTDIR = abs_path(dirname $0); -if ($^O eq 'VMS') { # clean up directory spec - $INSTDIR = VMS::Filespec::unixpath($INSTDIR); - $INSTDIR =~ s#/$##; - $INSTDIR =~ s#/000000/#/#; -} -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); -my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), - catfile($INSTDIR, 'scripts'), - catfile($INSTDIR, 'pod'), - catfile($INSTDIR, 't', 'pod') - ); -print "PODINCDIRS = ",join(', ',@PODINCDIRS),"\n"; - -## Find the path to the file to =include -sub findinclude { - my $self = shift; - my $incname = shift; - - ## See if its already found w/out any "searching; - return $incname if (-r $incname); - - ## Need to search for it. Look in the following directories ... - ## 1. the directory containing this pod file - my $thispoddir = dirname $self->input_file; - ## 2. the parent directory of the above - my $parentdir = dirname $thispoddir; - my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); - - for (@podincdirs) { - my $incfile = catfile($_, $incname); - return $incfile if (-r $incfile); - } - warn("*** Can't find =include file $incname in @podincdirs\n"); - return ""; -} - -sub command { - my $self = shift; - my ($cmd, $text, $line_num, $pod_para) = @_; - $cmd = '' unless (defined $cmd); - local $_ = $text || ''; - my $out_fh = $self->output_handle; - - ## Defer to the superclass for everything except '=include' - return $self->SUPER::command(@_) unless ($cmd eq "include"); - - ## We have an '=include' command - my $incdebug = 1; ## debugging - my @incargs = split; - if (@incargs == 0) { - warn("*** No filename given for '=include'\n"); - return; - } - my $incfile = $self->findinclude(shift @incargs) or return; - my $incbase = basename $incfile; - print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); - $self->parse_from_file( {-cutting => 1}, $incfile ); - print $out_fh "###### end =include $incbase #####\n" if ($incdebug); -} - -sub begin_input { - $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; -} - -sub podinc2plaintext( $ $ ) { - my ($infile, $outfile) = @_; - local $_; - my $text_parser = $MYPKG->new(quotes => "`'"); - $text_parser->parse_from_file($infile, $outfile); -} - -sub testpodinc2plaintext( @ ) { - my %args = @_; - my $infile = $args{'-In'} || croak "No input file given!"; - my $outfile = $args{'-Out'} || croak "No output file given!"; - my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; - - my $different = ''; - my $testname = basename $cmpfile, '.t', '.xr'; - - unless (-e $cmpfile) { - my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; - warn "$msg\n"; - return $msg; - } - - print "# Running testpodinc2plaintext for '$testname'...\n"; - ## Compare the output against the expected result - podinc2plaintext($infile, $outfile); - if ( testcmp($outfile, $cmpfile) ) { - $different = "$outfile is different from $cmpfile"; - } - else { - unlink($outfile); - } - return $different; -} - -sub testpodplaintext( @ ) { - my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); - my @testpods = @_; - my ($testname, $testdir) = ("", ""); - my ($podfile, $cmpfile) = ("", ""); - my ($outfile, $errfile) = ("", ""); - my $passes = 0; - my $failed = 0; - local $_; - - print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); - - for $podfile (@testpods) { - ($testname, $_) = fileparse($podfile); - $testdir ||= $_; - $testname =~ s/\.t$//; - $cmpfile = $testdir . $testname . '.xr'; - $outfile = $testdir . $testname . '.OUT'; - - if ($opts{'-xrgen'}) { - if ($opts{'-force'} or ! -e $cmpfile) { - ## Create the comparison file - print "# Creating expected result for \"$testname\"" . - " pod2plaintext test ...\n"; - podinc2plaintext($podfile, $cmpfile); - } - else { - print "# File $cmpfile already exists" . - " (use '-force' to regenerate it).\n"; - } - next; - } - - my $failmsg = testpodinc2plaintext - -In => $podfile, - -Out => $outfile, - -Cmp => $cmpfile; - if ($failmsg) { - ++$failed; - print "#\tFAILED. ($failmsg)\n"; - print "not ok ", $failed+$passes, "\n"; - } - else { - ++$passes; - unlink($outfile); - print "#\tPASSED.\n"; - print "ok ", $failed+$passes, "\n"; - } - } - return $passes; -} - -1; diff --git a/contrib/perl5/t/pod/testpchk.pl b/contrib/perl5/t/pod/testpchk.pl deleted file mode 100644 index 8aa10b9..0000000 --- a/contrib/perl5/t/pod/testpchk.pl +++ /dev/null @@ -1,129 +0,0 @@ -package TestPodChecker; - -BEGIN { - use File::Basename; - use File::Spec; - push @INC, '..'; - my $THISDIR = dirname $0; - unshift @INC, $THISDIR; - require "testcmp.pl"; - import TestCompare; - my $PARENTDIR = dirname $THISDIR; - push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); - require VMS::Filespec if $^O eq 'VMS'; -} - -use Pod::Checker; -use vars qw(@ISA @EXPORT $MYPKG); -#use strict; -#use diagnostics; -use Carp; -use Exporter; -#use File::Compare; - -@ISA = qw(Exporter); -@EXPORT = qw(&testpodchecker); -$MYPKG = eval { (caller)[0] }; - -sub stripname( $ ) { - local $_ = shift; - return /(\w[.\w]*)\s*$/ ? $1 : $_; -} - -sub msgcmp( $ $ ) { - ## filter out platform-dependent aspects of error messages - my ($line1, $line2) = @_; - for ($line1, $line2) { - ## remove filenames from error messages to avoid any - ## filepath naming differences between OS platforms - s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/; - s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/; - } - return ($line1 ne $line2); -} - -sub testpodcheck( @ ) { - my %args = @_; - my $infile = $args{'-In'} || croak "No input file given!"; - my $outfile = $args{'-Out'} || croak "No output file given!"; - my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; - - my $different = ''; - my $testname = basename $cmpfile, '.t', '.xr'; - - unless (-e $cmpfile) { - my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; - warn "$msg\n"; - return $msg; - } - - print "# Running podchecker for '$testname'...\n"; - ## Compare the output against the expected result - if ($^O eq 'VMS') { - for ($infile, $outfile, $cmpfile) { - $_ = VMS::Filespec::unixify($_) unless ref; - } - } - podchecker($infile, $outfile); - if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { - $different = "$outfile is different from $cmpfile"; - } - else { - unlink($outfile); - } - return $different; -} - -sub testpodchecker( @ ) { - my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); - my @testpods = @_; - my ($testname, $testdir) = ("", ""); - my ($podfile, $cmpfile) = ("", ""); - my ($outfile, $errfile) = ("", ""); - my $passes = 0; - my $failed = 0; - local $_; - - print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); - - for $podfile (@testpods) { - ($testname, $_) = fileparse($podfile); - $testdir ||= $_; - $testname =~ s/\.t$//; - $cmpfile = $testdir . $testname . '.xr'; - $outfile = $testdir . $testname . '.OUT'; - - if ($opts{'-xrgen'}) { - if ($opts{'-force'} or ! -e $cmpfile) { - ## Create the comparison file - print "# Creating expected result for \"$testname\"" . - " podchecker test ...\n"; - podchecker($podfile, $cmpfile); - } - else { - print "# File $cmpfile already exists" . - " (use '-force' to regenerate it).\n"; - } - next; - } - - my $failmsg = testpodcheck - -In => $podfile, - -Out => $outfile, - -Cmp => $cmpfile; - if ($failmsg) { - ++$failed; - print "#\tFAILED. ($failmsg)\n"; - print "not ok ", $failed+$passes, "\n"; - } - else { - ++$passes; - unlink($outfile); - print "#\tPASSED.\n"; - print "ok ", $failed+$passes, "\n"; - } - } - return $passes; -} - -1; diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t deleted file mode 100755 index 6e6617b..0000000 --- a/contrib/perl5/t/pragma/constant.t +++ /dev/null @@ -1,230 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use vars qw{ @warnings }; -BEGIN { # ...and save 'em for later - $SIG{'__WARN__'} = sub { push @warnings, @_ } -} -END { print @warnings } - -######################### We start with some black magic to print on failure. - -BEGIN { $| = 1; print "1..73\n"; } -END {print "not ok 1\n" unless $loaded;} -use constant 1.01; -$loaded = 1; -#print "# Version: $constant::VERSION\n"; -print "ok 1\n"; - -######################### End of black magic. - -use strict; - -sub test ($$;$) { - my($num, $bool, $diag) = @_; - if ($bool) { - print "ok $num\n"; - return; - } - print "not ok $num\n"; - return unless defined $diag; - $diag =~ s/\Z\n?/\n/; # unchomp - print map "# $num : $_", split m/^/m, $diag; -} - -use constant PI => 4 * atan2 1, 1; - -test 2, substr(PI, 0, 7) eq '3.14159'; -test 3, defined PI; - -sub deg2rad { PI * $_[0] / 180 } - -my $ninety = deg2rad 90; - -test 4, $ninety > 1.5707; -test 5, $ninety < 1.5708; - -use constant UNDEF1 => undef; # the right way -use constant UNDEF2 => ; # the weird way -use constant 'UNDEF3' ; # the 'short' way -use constant EMPTY => ( ) ; # the right way for lists - -test 6, not defined UNDEF1; -test 7, not defined UNDEF2; -test 8, not defined UNDEF3; -my @undef = UNDEF1; -test 9, @undef == 1; -test 10, not defined $undef[0]; -@undef = UNDEF2; -test 11, @undef == 0; -@undef = UNDEF3; -test 12, @undef == 0; -@undef = EMPTY; -test 13, @undef == 0; - -use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; -use constant COUNTLIST => reverse 1, 2, 3, 4, 5; -use constant COUNTLAST => (COUNTLIST)[-1]; - -test 14, COUNTDOWN eq '54321'; -my @cl = COUNTLIST; -test 15, @cl == 5; -test 16, COUNTDOWN eq join '', @cl; -test 17, COUNTLAST == 1; -test 18, (COUNTLIST)[1] == 4; - -use constant ABC => 'ABC'; -test 19, "abc${\( ABC )}abc" eq "abcABCabc"; - -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 => "'"; -use constant DOUBLE => '"'; -use constant BACK => '\\'; -my $tt = BACK . SINGLE . DOUBLE ; -test 21, $tt eq q(\\'"); - -use constant MESS => q('"'\\"'"\\); -test 22, MESS eq q('"'\\"'"\\); -test 23, length(MESS) == 8; - -use constant TRAILING => '12 cats'; -{ - no warnings 'numeric'; - test 24, TRAILING == 12; -} -test 25, TRAILING eq '12 cats'; - -use constant LEADING => " \t1234"; -test 26, LEADING == 1234; -test 27, LEADING eq " \t1234"; - -use constant ZERO1 => 0; -use constant ZERO2 => 0.0; -use constant ZERO3 => '0.0'; -test 28, ZERO1 eq '0'; -test 29, ZERO2 eq '0'; -test 30, ZERO3 eq '0.0'; - -{ - package Other; - use constant PI => 3.141; -} - -test 31, (PI > 3.1415 and PI < 3.1416); -test 32, Other::PI == 3.141; - -use constant E2BIG => $! = 7; -test 33, E2BIG == 7; -# This is something like "Arg list too long", but the actual message -# text may vary, so we can't test much better than this. -test 34, length(E2BIG) > 6; -test 35, index(E2BIG, " ") > 0; - -test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; -@warnings = (); # just in case -undef &PI; -test 37, @warnings && - ($warnings[0] =~ /Constant sub.* undefined/), - shift @warnings; - -test 38, @warnings == 0, "unexpected warning"; -test 39, 1; - -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 pseudo-hash field/); -print CCODE->(45); -eval q{ CCODE->{foo} }; -test 46, scalar($@ =~ /^Constant is not a HASH/); - -# Allow leading underscore -use constant _PRIVATE => 47; -test 47, _PRIVATE == 47; - -# Disallow doubled leading underscore -eval q{ - use constant __DISALLOWED => "Oops"; -}; -test 48, $@ =~ /begins with '__'/; - -# Check on declared() and %declared. This sub should be EXACTLY the -# same as the one quoted in the docs! -sub declared ($) { - use constant 1.01; # don't omit this! - my $name = shift; - $name =~ s/^::/main::/; - my $pkg = caller; - my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; - $constant::declared{$full_name}; -} - -test 49, declared 'PI'; -test 50, $constant::declared{'main::PI'}; - -test 51, !declared 'PIE'; -test 52, !$constant::declared{'main::PIE'}; - -{ - package Other; - use constant IN_OTHER_PACK => 42; - ::test 53, ::declared 'IN_OTHER_PACK'; - ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; - ::test 55, ::declared 'main::PI'; - ::test 56, $constant::declared{'main::PI'}; -} - -test 57, declared 'Other::IN_OTHER_PACK'; -test 58, $constant::declared{'Other::IN_OTHER_PACK'}; - -@warnings = (); -eval q{ - no warnings; - use warnings 'constant'; - use constant 'BEGIN' => 1 ; - use constant 'INIT' => 1 ; - use constant 'CHECK' => 1 ; - use constant 'END' => 1 ; - use constant 'DESTROY' => 1 ; - use constant 'AUTOLOAD' => 1 ; - use constant 'STDIN' => 1 ; - use constant 'STDOUT' => 1 ; - use constant 'STDERR' => 1 ; - use constant 'ARGV' => 1 ; - use constant 'ARGVOUT' => 1 ; - use constant 'ENV' => 1 ; - use constant 'INC' => 1 ; - use constant 'SIG' => 1 ; -}; - -test 59, @warnings == 14 ; -test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; -test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; -test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; -test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; -test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; -test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; -test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; -test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; -test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; -test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; -test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; -test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; -test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; -test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; -@warnings = (); diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t deleted file mode 100755 index 14014f6..0000000 --- a/contrib/perl5/t/pragma/diagnostics.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl - -BEGIN { - chdir '..' if -d '../pod' && -d '../t'; - @INC = 'lib'; -} - - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) -use strict; -use warnings; - -use vars qw($Test_Num $Total_tests); - -my $loaded; -BEGIN { $| = 1; $Test_Num = 1 } -END {print "not ok $Test_Num\n" unless $loaded;} -print "1..$Total_tests\n"; -BEGIN { require diagnostics; } # Don't want diagnostics' noise yet. -$loaded = 1; -ok($loaded, 'compile'); -######################### End of black magic. - -sub ok { - my($test, $name) = shift; - print "not " unless $test; - print "ok $Test_Num"; - print " - $name" if defined $name; - print "\n"; - $Test_Num++; -} - - -# Change this to your # of ok() calls + 1 -BEGIN { $Total_tests = 1 } diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t deleted file mode 100755 index 068fede..0000000 --- a/contrib/perl5/t/pragma/locale.t +++ /dev/null @@ -1,807 +0,0 @@ -#!./perl -wT - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - unshift @INC, '.'; - require Config; import Config; - if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { - print "1..0\n"; - exit; - } -} - -use strict; - -my $debug = 1; - -use Dumpvalue; - -my $dumper = Dumpvalue->new( - tick => qq{"}, - quoteHighBit => 0, - unctrl => "quote" - ); -sub debug { - return unless $debug; - my($mess) = join "", @_; - chop $mess; - print $dumper->stringify($mess,1), "\n"; -} - -sub debugf { - printf @_ if $debug; -} - -my $have_setlocale = 0; -eval { - require POSIX; - import POSIX ':locale_h'; - $have_setlocale++; -}; - -# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" -# and mingw32 uses said silly CRT -$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; - -my $last = $have_setlocale ? 116 : 98; - -print "1..$last\n"; - -use vars qw(&LC_ALL); - -my $a = 'abc %'; - -sub ok { - my ($n, $result) = @_; - - print 'not ' unless ($result); - print "ok $n\n"; -} - -# First we'll do a lot of taint checking for locales. -# This is the easiest to test, actually, as any locale, -# even the default locale will taint under 'use locale'. - -sub is_tainted { # hello, camel two. - no warnings 'uninitialized' ; - my $dummy; - not eval { $dummy = join("", @_), kill 0; 1 } -} - -sub check_taint ($$) { - ok $_[0], is_tainted($_[1]); -} - -sub check_taint_not ($$) { - ok $_[0], not is_tainted($_[1]); -} - -use locale; # engage locale and therefore locale taint. - -check_taint_not 1, $a; - -check_taint 2, uc($a); -check_taint 3, "\U$a"; -check_taint 4, ucfirst($a); -check_taint 5, "\u$a"; -check_taint 6, lc($a); -check_taint 7, "\L$a"; -check_taint 8, lcfirst($a); -check_taint 9, "\l$a"; - -check_taint_not 10, sprintf('%e', 123.456); -check_taint_not 11, sprintf('%f', 123.456); -check_taint_not 12, sprintf('%g', 123.456); -check_taint_not 13, sprintf('%d', 123.456); -check_taint_not 14, sprintf('%x', 123.456); - -$_ = $a; # untaint $_ - -$_ = uc($a); # taint $_ - -check_taint 15, $_; - -/(\w)/; # taint $&, $`, $', $+, $1. -check_taint 16, $&; -check_taint 17, $`; -check_taint 18, $'; -check_taint 19, $+; -check_taint 20, $1; -check_taint_not 21, $2; - -/(.)/; # untaint $&, $`, $', $+, $1. -check_taint_not 22, $&; -check_taint_not 23, $`; -check_taint_not 24, $'; -check_taint_not 25, $+; -check_taint_not 26, $1; -check_taint_not 27, $2; - -/(\W)/; # taint $&, $`, $', $+, $1. -check_taint 28, $&; -check_taint 29, $`; -check_taint 30, $'; -check_taint 31, $+; -check_taint 32, $1; -check_taint_not 33, $2; - -/(\s)/; # taint $&, $`, $', $+, $1. -check_taint 34, $&; -check_taint 35, $`; -check_taint 36, $'; -check_taint 37, $+; -check_taint 38, $1; -check_taint_not 39, $2; - -/(\S)/; # taint $&, $`, $', $+, $1. -check_taint 40, $&; -check_taint 41, $`; -check_taint 42, $'; -check_taint 43, $+; -check_taint 44, $1; -check_taint_not 45, $2; - -$_ = $a; # untaint $_ - -check_taint_not 46, $_; - -/(b)/; # this must not taint -check_taint_not 47, $&; -check_taint_not 48, $`; -check_taint_not 49, $'; -check_taint_not 50, $+; -check_taint_not 51, $1; -check_taint_not 52, $2; - -$_ = $a; # untaint $_ - -check_taint_not 53, $_; - -$b = uc($a); # taint $b -s/(.+)/$b/; # this must taint only the $_ - -check_taint 54, $_; -check_taint_not 55, $&; -check_taint_not 56, $`; -check_taint_not 57, $'; -check_taint_not 58, $+; -check_taint_not 59, $1; -check_taint_not 60, $2; - -$_ = $a; # untaint $_ - -s/(.+)/b/; # this must not taint -check_taint_not 61, $_; -check_taint_not 62, $&; -check_taint_not 63, $`; -check_taint_not 64, $'; -check_taint_not 65, $+; -check_taint_not 66, $1; -check_taint_not 67, $2; - -$b = $a; # untaint $b - -($b = $a) =~ s/\w/$&/; -check_taint 68, $b; # $b should be tainted. -check_taint_not 69, $a; # $a should be not. - -$_ = $a; # untaint $_ - -s/(\w)/\l$1/; # this must taint -check_taint 70, $_; -check_taint 71, $&; -check_taint 72, $`; -check_taint 73, $'; -check_taint 74, $+; -check_taint 75, $1; -check_taint_not 76, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\L$1/; # this must taint -check_taint 77, $_; -check_taint 78, $&; -check_taint 79, $`; -check_taint 80, $'; -check_taint 81, $+; -check_taint 82, $1; -check_taint_not 83, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\u$1/; # this must taint -check_taint 84, $_; -check_taint 85, $&; -check_taint 86, $`; -check_taint 87, $'; -check_taint 88, $+; -check_taint 89, $1; -check_taint_not 90, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\U$1/; # this must taint -check_taint 91, $_; -check_taint 92, $&; -check_taint 93, $`; -check_taint 94, $'; -check_taint 95, $+; -check_taint 96, $1; -check_taint_not 97, $2; - -# After all this tainting $a should be cool. - -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). - -exit unless $have_setlocale; - -# 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 Big5 GB2312 tw.EUC -Hrvatski Croatian:hr:hr:2 -Cymraeg Welsh:cy:cy:1 14 15 -Czech:cs:cz:2 -Dansk Danish:dk:da:1 15 -Nederlands Dutch:nl:be nl:1 15 -English American British:en:au ca gb ie nz us uk zw: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 -Moldovan:mo:mo:2 -Norsk Norwegian:no no\@nynorsk:no:1 15 -Occitan:oc:es:1 15 -Polski Polish:pl:pl:2 -Rumanian:ro:ro:2 -Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 -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:yi::1 15 -EOF - -if ($^O eq 'os390') { - # These cause heartburn. Broken locales? - $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; - $locales =~ s/Thai:th:th:11 tis620\n//; -} - -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 trylocale { - my $locale = shift; - if (setlocale(LC_ALL, $locale)) { - push @Locale, $locale; - } -} - -sub decode_encodings { - my @enc; - - 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, $_; - push @enc, "$_.UTF-8"; - } - } - if ($^O eq 'os390') { - push @enc, qw(IBM-037 IBM-819 IBM-1047); - } - - return @enc; -} - -trylocale("C"); -trylocale("POSIX"); -foreach (0..15) { - trylocale("ISO8859-$_"); - trylocale("iso8859$_"); - trylocale("iso8859-$_"); - trylocale("iso_8859_$_"); - trylocale("isolatin$_"); - trylocale("isolatin-$_"); - trylocale("iso_latin_$_"); -} - -# Sanitize the environment so that we can run the external 'locale' -# program without the taint mode getting grumpy. - -# $ENV{PATH} is special in VMS. -delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; - -# Other subversive stuff. -delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; - -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { - while (<LOCALES>) { - chomp; - trylocale($_); - } - close(LOCALES); -} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { -# The SYS$I18N_LOCALE logical name search list was not present on -# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. - opendir(LOCALES, "SYS\$I18N_LOCALE:"); - while ($_ = readdir(LOCALES)) { - chomp; - trylocale($_); - } - close(LOCALES); -} else { - - # This is going to be slow. - - foreach my $locale (split(/\n/, $locales)) { - my ($locale_name, $language_codes, $country_codes, $encodings) = - split(/:/, $locale); - my @enc = decode_encodings($encodings); - foreach my $loc (split(/ /, $locale_name)) { - trylocale($loc); - foreach my $enc (@enc) { - trylocale("$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"); - -sub utf8locale { $_[0] =~ /utf-?8/i } - -@Locale = sort @Locale; - -debug "# Locales = @Locale\n"; - -my %Problem; -my %Okay; -my %Testing; -my @Neoalpha; -my %Neoalpha; - -sub tryneoalpha { - my ($Locale, $i, $test) = @_; - unless ($test) { - $Problem{$i}{$Locale} = 1; - debug "# failed $i with locale '$Locale'\n"; - } else { - push @{$Okay{$i}}, $Locale; - } -} - -foreach $Locale (@Locale) { - debug "# Locale = $Locale\n"; - @Alnum_ = getalnum_(); - debug "# w = ", join("",@Alnum_), "\n"; - - unless (setlocale(LC_ALL, $Locale)) { - foreach (99..103) { - $Problem{$_}{$Locale} = -1; - } - next; - } - - # Sieve the uppercase and the lowercase. - - my %UPPER = (); - my %lower = (); - my %BoThCaSe = (); - for (@Alnum_) { - if (/[^\d_]/) { # skip digits and the _ - if (uc($_) eq $_) { - $UPPER{$_} = $_; - } - if (lc($_) eq $_) { - $lower{$_} = $_; - } - } - } - foreach (keys %UPPER) { - $BoThCaSe{$_}++ if exists $lower{$_}; - } - foreach (keys %lower) { - $BoThCaSe{$_}++ if exists $UPPER{$_}; - } - foreach (keys %BoThCaSe) { - delete $UPPER{$_}; - delete $lower{$_}; - } - - 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/); - $Neoalpha{$_} = $_; - } - } - - @Neoalpha = sort @Neoalpha; - - debug "# Neoalpha = ", join("",@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. - - if (utf8locale($Locale)) { - # Until the polymorphic regexen arrive. - debug "# skipping UTF-8 locale '$Locale'\n"; - } else { - 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; - } - } - } - } - - use locale; - - my ($x, $y) = (1.23, 1.23); - - my $a = "$x"; - printf ''; # printf used to reset locale to "C" - my $b = "$y"; - - debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; - - tryneoalpha($Locale, 103, $a eq $b); - - my $c = "$x"; - my $z = sprintf ''; # sprintf used to reset locale to "C" - my $d = "$y"; - - debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; - - tryneoalpha($Locale, 104, $c eq $d); - - { - use warnings; - my $w = 0; - local $SIG{__WARN__} = sub { $w++ }; - - # the == (among other ops) used to warn for locales - # that had something else than "." as the radix character - - tryneoalpha($Locale, 105, $c == 1.23); - - tryneoalpha($Locale, 106, $c == $x); - - tryneoalpha($Locale, 107, $c == $d); - - { - no locale; - - my $e = "$x"; - - debug "# 108..110: e = $e, Locale = $Locale\n"; - - tryneoalpha($Locale, 108, $e == 1.23); - - tryneoalpha($Locale, 109, $e == $x); - - tryneoalpha($Locale, 110, $e == $c); - } - - tryneoalpha($Locale, 111, $w == 0); - - my $f = "1.23"; - - debug "# 112..114: f = $f, locale = $Locale\n"; - - tryneoalpha($Locale, 112, $f == 1.23); - - tryneoalpha($Locale, 113, $f == $x); - - tryneoalpha($Locale, 114, $f == $c); - } - - # Does taking lc separately differ from taking - # the lc "in-line"? (This was the bug 19990704.002, change #3568.) - # The bug was in the caching of the 'o'-magic. - { - use locale; - - sub lcA { - my $lc0 = lc $_[0]; - my $lc1 = lc $_[1]; - return $lc0 cmp $lc1; - } - - sub lcB { - return lc($_[0]) cmp lc($_[1]); - } - - my $x = "ab"; - my $y = "aa"; - my $z = "AB"; - - tryneoalpha($Locale, 115, - lcA($x, $y) == 1 && lcB($x, $y) == 1 || - lcA($x, $z) == 0 && lcB($x, $z) == 0); - } - - # Does lc of an UPPER (if different from the UPPER) match - # case-insensitively the UPPER, and does the UPPER match - # case-insensitively the lc of the UPPER. And vice versa. - if (utf8locale($Locale)) { - # Until the polymorphic regexen arrive. - debug "# skipping UTF-8 locale '$Locale'\n"; - } else { - use locale; - - my @f = (); - foreach my $x (keys %UPPER) { - my $y = lc $x; - next unless uc $y eq $x; - push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; - } - foreach my $x (keys %lower) { - my $y = uc $x; - next unless lc $y eq $x; - push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; - } - tryneoalpha($Locale, 116, @f == 0); - if (@f) { - print "# failed 116 locale '$Locale' characters @f\n" - } - } - -} - -# Recount the errors. - -foreach (99..$last) { - 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"; -} - -# Give final advice. - -my $didwarn = 0; - -foreach (99..$last) { - 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; - } -} - -# Tell which locales were okay and which were not. - -if ($didwarn) { - my (@s, @F); - - foreach my $l (@Locale) { - my $p = 0; - foreach my $t (102..$last) { - $p++ if $Problem{$t}{$l}; - } - push @s, $l if $p == 0; - push @F, $l unless $p == 0; - } - - if (@s) { - my $s = join(" ", @s); - $s =~ s/(.{50,60}) /$1\n#\t/g; - - warn - "# The following locales\n#\n", - "#\t", $s, "\n#\n", - "# tested okay.\n#\n", - } else { - warn "# None of your locales were fully okay.\n"; - } - - if (@F) { - my $F = join(" ", @F); - $F =~ s/(.{50,60}) /$1\n#\t/g; - - warn - "# The following locales\n#\n", - "#\t", $F, "\n#\n", - "# had problems.\n#\n", - } else { - warn "# None of your locales were broken.\n"; - } -} - -# eof diff --git a/contrib/perl5/t/pragma/locale/latin1 b/contrib/perl5/t/pragma/locale/latin1 deleted file mode 100644 index f40f732..0000000 --- a/contrib/perl5/t/pragma/locale/latin1 +++ /dev/null @@ -1,10 +0,0 @@ -$locales .= <<EOF; -Catal Catalan:ca:es:1 15 -Franais French:fr:be ca ch fr lu:1 15 -Gidhlig Gaelic:gd:gb uk:1 14 15 -Froyskt Faroese:fo:fo:1 15 -slensku Icelandic:is:is:1 15 -Smi Lappish:::4 6 13 -Portugus Portuguese:po:po br:1 15 -Espanl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 -EOF diff --git a/contrib/perl5/t/pragma/locale/utf8 b/contrib/perl5/t/pragma/locale/utf8 deleted file mode 100644 index fbbe94f..0000000 --- a/contrib/perl5/t/pragma/locale/utf8 +++ /dev/null @@ -1,10 +0,0 @@ -$locales .= <<EOF; -Català Catalan:ca:es:1 15 -Français French:fr:be ca ch fr lu:1 15 -Gáidhlig Gaelic:gd:gb uk:1 14 15 -Føroyskt Faroese:fo:fo:1 15 -Íslensku Icelandic:is:is:1 15 -Sámi Lappish:::4 6 13 -Português Portuguese:po:po br:1 15 -Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 -EOF diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t deleted file mode 100755 index a3007ef..0000000 --- a/contrib/perl5/t/pragma/overload.t +++ /dev/null @@ -1,987 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -package Oscalar; -use overload ( - # Anonymous subroutines: -'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, -'-' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'<=>' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'cmp' => sub {new Oscalar - $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, -'*' => sub {new Oscalar ${$_[0]}*$_[1]}, -'/' => sub {new Oscalar - $_[2]? $_[1]/${$_[0]} : - ${$_[0]}/$_[1]}, -'%' => sub {new Oscalar - $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, -'**' => sub {new Oscalar - $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, - -qw( -"" stringify -0+ numify) # Order of arguments unsignificant -); - -sub new { - my $foo = $_[1]; - bless \$foo, $_[0]; -} - -sub stringify { "${$_[0]}" } -sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead - # comparing to direct compilation based on - # stringify - -package main; - -$test = 0; -$| = 1; -print "1..",&last,"\n"; - -sub test { - $test++; - if (@_ > 1) { - if ($_[0] eq $_[1]) { - print "ok $test\n"; - } else { - print "not ok $test: '$_[0]' ne '$_[1]'\n"; - } - } else { - if (shift) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - } - } -} - -$a = new Oscalar "087"; -$b= "$a"; - -# All test numbers in comments are off by 1. -# So much for hard-wiring them in :-) To fix this: -test(1); # 1 - -test ($b eq $a); # 2 -test ($b eq "087"); # 3 -test (ref $a eq "Oscalar"); # 4 -test ($a eq $a); # 5 -test ($a eq "087"); # 6 - -$c = $a + 7; - -test (ref $c eq "Oscalar"); # 7 -test (!($c eq $a)); # 8 -test ($c eq "94"); # 9 - -$b=$a; - -test (ref $a eq "Oscalar"); # 10 - -$b++; - -test (ref $b eq "Oscalar"); # 11 -test ( $a eq "087"); # 12 -test ( $b eq "88"); # 13 -test (ref $a eq "Oscalar"); # 14 - -$c=$b; -$c-=$a; - -test (ref $c eq "Oscalar"); # 15 -test ( $a eq "087"); # 16 -test ( $c eq "1"); # 17 -test (ref $a eq "Oscalar"); # 18 - -$b=1; -$b+=$a; - -test (ref $b eq "Oscalar"); # 19 -test ( $a eq "087"); # 20 -test ( $b eq "88"); # 21 -test (ref $a eq "Oscalar"); # 22 - -eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 23 - -$b++; - -test (ref $b eq "Oscalar"); # 24 -test ( $a eq "087"); # 25 -test ( $b eq "88"); # 26 -test (ref $a eq "Oscalar"); # 27 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 28 -test ( $a eq "087"); # 29 -test ( $b eq "88"); # 30 -test (ref $a eq "Oscalar"); # 31 - - -eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 32 - -$b++; - -test (ref $b eq "Oscalar"); # 33 -test ( $a eq "087"); # 34 -test ( $b eq "88"); # 35 -test (ref $a eq "Oscalar"); # 36 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b++; - -test (ref $b eq "Oscalar"); # 37 -test ( $a eq "087"); # 38 -test ( $b eq "90"); # 39 -test (ref $a eq "Oscalar"); # 40 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 41 -test ( $a eq "087"); # 42 -test ( $b eq "89"); # 43 -test (ref $a eq "Oscalar"); # 44 - - -test ($b? 1:0); # 45 - -eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; - package Oscalar; - local $new=$ {$_[0]}; - bless \$new } ) ]; - -$b=new Oscalar "$a"; - -test (ref $b eq "Oscalar"); # 46 -test ( $a eq "087"); # 47 -test ( $b eq "087"); # 48 -test (ref $a eq "Oscalar"); # 49 - -$b++; - -test (ref $b eq "Oscalar"); # 50 -test ( $a eq "087"); # 51 -test ( $b eq "89"); # 52 -test (ref $a eq "Oscalar"); # 53 -test ($copies == 0); # 54 - -$b+=1; - -test (ref $b eq "Oscalar"); # 55 -test ( $a eq "087"); # 56 -test ( $b eq "90"); # 57 -test (ref $a eq "Oscalar"); # 58 -test ($copies == 0); # 59 - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 60 -test ( $a eq "087"); # 61 -test ( $b eq "88"); # 62 -test (ref $a eq "Oscalar"); # 63 -test ($copies == 0); # 64 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 -test ( $a eq "087"); # 66 -test ( $b eq "89"); # 67 -test (ref $a eq "Oscalar"); # 68 -test ($copies == 1); # 69 - -eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; - $_[0] } ) ]; -$c=new Oscalar; # Cause rehash - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 70 -test ( $a eq "087"); # 71 -test ( $b eq "90"); # 72 -test (ref $a eq "Oscalar"); # 73 -test ($copies == 2); # 74 - -$b+=$b; - -test (ref $b eq "Oscalar"); # 75 -test ( $b eq "360"); # 76 -test ($copies == 2); # 77 -$b=-$b; - -test (ref $b eq "Oscalar"); # 78 -test ( $b eq "-360"); # 79 -test ($copies == 2); # 80 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 81 -test ( $b eq "360"); # 82 -test ($copies == 2); # 83 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 84 -test ( $b eq "360"); # 85 -test ($copies == 2); # 86 - -eval q[package Oscalar; - use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} - : "_.${$_[0]}._" x $_[1])}) ]; - -$a=new Oscalar "yy"; -$a x= 3; -test ($a eq "_.yy.__.yy.__.yy._"); # 87 - -eval q[package Oscalar; - use overload ('.' => sub {new Oscalar ( $_[2] ? - "_.$_[1].__.$ {$_[0]}._" - : "_.$ {$_[0]}.__.$_[1]._")}) ]; - -$a=new Oscalar "xx"; - -test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 - -# Check inheritance of overloading; -{ - package OscalarI; - @ISA = 'Oscalar'; -} - -$aI = new OscalarI "$a"; -test (ref $aI eq "OscalarI"); # 89 -test ("$aI" eq "xx"); # 90 -test ($aI eq "xx"); # 91 -test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 - -# Here we test blessing to a package updates hash - -eval "package Oscalar; no overload '.'"; - -test ("b${a}" eq "_.b.__.xx._"); # 93 -$x="1"; -bless \$x, Oscalar; -test ("b${a}c" eq "bxxc"); # 94 -new Oscalar 1; -test ("b${a}c" eq "bxxc"); # 95 - -# Negative overloading: - -$na = eval { ~$a }; -test($@ =~ /no method found/); # 96 - -# Check AUTOLOADING: - -*Oscalar::AUTOLOAD = - sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; - goto &{"Oscalar::$AUTOLOAD"}}; - -eval "package Oscalar; sub comple; use overload '~' => 'comple'"; - -$na = eval { ~$a }; # Hash was not updated -test($@ =~ /no method found/); # 97 - -bless \$x, Oscalar; - -$na = eval { ~$a }; # Hash updated -warn "`$na', $@" if $@; -test !$@; # 98 -test($na eq '_!_xx_!_'); # 99 - -$na = 0; - -$na = eval { ~$aI }; # Hash was not updated -test($@ =~ /no method found/); # 100 - -bless \$x, OscalarI; - -$na = eval { ~$aI }; -print $@; - -test !$@; # 101 -test($na eq '_!_xx_!_'); # 102 - -eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; - -$na = eval { $aI >> 1 }; # Hash was not updated -test($@ =~ /no method found/); # 103 - -bless \$x, OscalarI; - -$na = 0; - -$na = eval { $aI >> 1 }; -print $@; - -test !$@; # 104 -test($na eq '_!_xx_!_'); # 105 - -# warn overload::Method($a, '0+'), "\n"; -test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 -test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 -test (overload::Overloaded($aI)); # 108 -test (!overload::Overloaded('overload')); # 109 - -test (! defined overload::Method($aI, '<<')); # 110 -test (! defined overload::Method($a, '<')); # 111 - -test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 -test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 - -# Check overloading by methods (specified deep in the ISA tree). -{ - package OscalarII; - @ISA = 'OscalarI'; - sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} - eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; -} - -$aaII = "087"; -$aII = \$aaII; -bless $aII, 'OscalarII'; -bless \$fake, 'OscalarI'; # update the hash -test(($aI | 3) eq '_<<_xx_<<_'); # 114 -# warn $aII << 3; -test(($aII << 3) eq '_<<_087_<<_'); # 115 - -{ - BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } - $out = 2**10; -} -test($int, 9); # 116 -test($out, 1024); # 117 - -$foo = 'foo'; -$foo1 = 'f\'o\\o'; -{ - BEGIN { $q = $qr = 7; - overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, - 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - /b\b$foo.\./; -} - -test($out, 'foo'); # 118 -test($out, $foo); # 119 -test($out1, 'f\'o\\o'); # 120 -test($out1, $foo1); # 121 -test($out2, "a\afoo,\,"); # 122 -test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 -test($q, 11); # 124 -test("@qr", "b\\b qq .\\. qq"); # 125 -test($qr, 9); # 126 - -{ - $_ = '!<b>!foo!<-.>!'; - BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, - 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - $res = /b\b$foo.\./; - $a = <<EOF; -oups -EOF - $b = <<'EOF'; -oups1 -EOF - $c = bareword; - m'try it'; - s'first part'second part'; - s/yet another/tail here/; - tr/z-Z/z-Z/; -} - -test($out, '_<foo>_'); # 117 -test($out1, '_<f\'o\\o>_'); # 128 -test($out2, "_<a\a>_foo_<,\,>_"); # 129 -test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups - qq oups1 - q second part q tail here s z-Z tr z-Z tr"); # 130 -test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 -test($res, 1); # 132 -test($a, "_<oups ->_"); # 133 -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--; } -} - -# XXX iterator overload not intended to work with CORE::GLOBAL? -if (defined &CORE::GLOBAL::glob) { - test '1', '1'; # 175 - test '1', '1'; # 176 - test '1', '1'; # 177 -} -else { - my $iter = iterator->new(5); - my $acc = ''; - my $out; - $acc .= " $out" while $out = <${iter}>; - test $acc, ' 5 4 3 2 1 0'; # 175 - $iter = iterator->new(5); - test scalar <${iter}>, '5'; # 176 - $acc = ''; - $acc .= " $out" while $out = <$iter>; - test $acc, ' 4 3 2 1 0'; # 177 -} -{ - package deref; - use overload '%{}' => \&hderef, '&{}' => \&cderef, - '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; - sub new { my ($p, $v) = @_; bless \$v, $p } - sub deref { - my ($self, $key) = (shift, shift); - my $class = ref $self; - bless $self, 'deref::dummy'; # Disable overloading of %{} - my $out = $self->{$key}; - bless $self, $class; # Restore overloading - $out; - } - sub hderef {shift->deref('h')} - sub aderef {shift->deref('a')} - sub cderef {shift->deref('c')} - sub gderef {shift->deref('g')} - sub sderef {shift->deref('s')} -} -{ - my $deref = bless { h => { foo => 5 , fake => 23 }, - c => sub {return shift() + 34}, - 's' => \123, - a => [11..13], - g => \*srt, - }, 'deref'; - # Hash: - my @cont = sort %$deref; - if ("\t" eq "\011") { # ascii - test "@cont", '23 5 fake foo'; # 178 - } - else { # ebcdic alpha-numeric sort order - test "@cont", 'fake foo 23 5'; # 178 - } - my @keys = sort keys %$deref; - test "@keys", 'fake foo'; # 179 - my @val = sort values %$deref; - test "@val", '23 5'; # 180 - test $deref->{foo}, 5; # 181 - test defined $deref->{bar}, ''; # 182 - my $key; - @keys = (); - push @keys, $key while $key = each %$deref; - @keys = sort @keys; - test "@keys", 'fake foo'; # 183 - test exists $deref->{bar}, ''; # 184 - test exists $deref->{foo}, 1; # 185 - # Code: - test $deref->(5), 39; # 186 - test &$deref(6), 40; # 187 - sub xxx_goto { goto &$deref } - test xxx_goto(7), 41; # 188 - my $srt = bless { c => sub {$b <=> $a} - }, 'deref'; - *srt = \&$srt; - my @sorted = sort srt 11, 2, 5, 1, 22; - test "@sorted", '22 11 5 2 1'; # 189 - # Scalar - test $$deref, 123; # 190 - # Code - @sorted = sort $srt 11, 2, 5, 1, 22; - test "@sorted", '22 11 5 2 1'; # 191 - # Array - test "@$deref", '11 12 13'; # 192 - test $#$deref, '2'; # 193 - my $l = @$deref; - test $l, 3; # 194 - test $deref->[2], '13'; # 195 - $l = pop @$deref; - test $l, 13; # 196 - $l = 1; - test $deref->[$l], '12'; # 197 - # Repeated dereference - my $double = bless { h => $deref, - }, 'deref'; - test $double->{foo}, 5; # 198 -} - -{ - package two_refs; - use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; - sub new { - my $p = shift; - bless \ [@_], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key] = shift; - } - sub FETCH { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key]; - } -} - -my $bar = new two_refs 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 199 -$bar->{three} = 13; -test $bar->[3], 13; # 200 - -{ - package two_refs_o; - @ISA = ('two_refs'); -} - -$bar = new two_refs_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 201 -$bar->{three} = 13; -test $bar->[3], 13; # 202 - -{ - package two_refs1; - use overload '%{}' => sub { ${shift()}->[1] }, - '@{}' => sub { ${shift()}->[0] }; - sub new { - my $p = shift; - my $a = [@_]; - my %h; - tie %h, $p, $a; - bless \ [$a, \%h], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key] = shift; - } - sub FETCH { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key]; - } -} - -$bar = new two_refs_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 203 -$bar->{three} = 13; -test $bar->[3], 13; # 204 - -{ - package two_refs1_o; - @ISA = ('two_refs1'); -} - -$bar = new two_refs1_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 205 -$bar->{three} = 13; -test $bar->[3], 13; # 206 - -{ - package B; - use overload bool => sub { ${+shift} }; -} - -my $aaa; -{ my $bbbb = 0; $aaa = bless \$bbbb, B } - -test !$aaa, 1; # 207 - -unless ($aaa) { - test 'ok', 'ok'; # 208 -} else { - test 'is not', 'ok'; # 208 -} - -# check that overload isn't done twice by join -{ my $c = 0; - package Join; - use overload '""' => sub { $c++ }; - my $x = join '', bless([]), 'pq', bless([]); - main::test $x, '0pq1'; # 209 -}; - -# Test module-specific warning -{ - # check the Odd number of arguments for overload::constant warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" ; ' ; - test($a eq "") ; # 210 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" ; ' ; - test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 -} - -{ - # check the `$_[0]' is not an overloadable type warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a eq "") ; # 212 - use warnings 'overload' ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a =~ /^`fred' is not an overloadable type at/); # 213 -} - -{ - # check the `$_[1]' is not a code reference warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a eq "") ; # 214 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a =~ /^`1' is not a code reference at/); # 215 -} - -# make sure that we don't inifinitely recurse -{ - my $c = 0; - package Recurse; - use overload '""' => sub { shift }, - '0+' => sub { shift }, - 'bool' => sub { shift }, - fallback => 1; - my $x = bless([]); - main::test("$x" =~ /Recurse=ARRAY/); # 216 - main::test($x); # 217 - main::test($x+0 =~ /Recurse=ARRAY/); # 218 -}; - -# Last test is: -sub last {218} diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs deleted file mode 100644 index 10599b0..0000000 --- a/contrib/perl5/t/pragma/strict-refs +++ /dev/null @@ -1,297 +0,0 @@ -Check strict refs functionality - -__END__ - -# no strict, should build & run ok. -my $fred ; -$b = "fred" ; -$a = $$b ; -$c = ${"def"} ; -$c = @{"def"} ; -$c = %{"def"} ; -$c = *{"def"} ; -$c = \&{"def"} ; -$c = def->[0]; -$c = def->{xyz}; -EXPECT - -######## - -# strict refs - error -use strict ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = $$b ; -EXPECT -Can't use an undefined value as a SCALAR reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = @$b ; -EXPECT -Can't use an undefined value as an ARRAY reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = %$b ; -EXPECT -Can't use an undefined value as a HASH reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = *$b ; -EXPECT -Can't use an undefined value as a symbol reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->[0] ; -EXPECT -Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->{barney} ; -EXPECT -Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. -######## - -# strict refs - no error -use strict ; -no strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict qw(subs vars) ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict 'refs' ; -my $fred ; -my $b = \$fred ; -my $a = $$b ; -EXPECT - -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - - ---FILE-- abc -my $a = ${"Fred"} ; -1; ---FILE-- -use strict 'refs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -1; ---FILE-- -require "./abc"; -my $a = ${"Fred"} ; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -${"Fred"} ; -require "./abc"; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -my $a = ${"Fred"} ; -use abc; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'refs' ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - no strict ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'refs' ; - my $a = ${"Fred"} ; -]; print STDERR $@; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - no strict ; - my $a = ${"Fred"} ; -'; print STDERR $@; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/contrib/perl5/t/pragma/strict-subs b/contrib/perl5/t/pragma/strict-subs deleted file mode 100644 index ed4fe7a..0000000 --- a/contrib/perl5/t/pragma/strict-subs +++ /dev/null @@ -1,319 +0,0 @@ -Check strict subs functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(refs vars); -Fred ; -EXPECT - -######## - -use strict ; -no strict 'subs' ; -Fred ; -EXPECT - -######## - -# strict subs - error -use strict 'subs' ; -Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict 'subs' ; -my @a = (A..Z); -EXPECT -Bareword "Z" not allowed while "strict subs" in use at - line 4. -Bareword "A" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict 'subs' ; -my $a = (B..Y); -EXPECT -Bareword "Y" not allowed while "strict subs" in use at - line 4. -Bareword "B" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict ; -Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - no error -use strict 'subs' ; -sub Fred {} -Fred ; -EXPECT - -######## - -# Check compile time scope of strict subs pragma -use strict 'subs' ; -{ - no strict ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict subs pragma -no strict; -{ - use strict 'subs' ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -use strict 'subs' ; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -my $a = Fred ; -1; ---FILE-- -use strict 'subs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -1; ---FILE-- -require "./abc"; -my $a = Fred ; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -require "./abc"; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -use abc; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'subs' ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 5. -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - no strict ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - Fred ; -'; print STDERR $@ ; -Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'subs' ; - Fred ; -]; print STDERR $@; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - Fred ; -'; print STDERR $@ ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - no strict ; - my $a = Fred ; -'; print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# see if Foo->Bar(...) etc work under strictures -use strict; -package Foo; sub Bar { print "@_\n" } -Foo->Bar('a',1); -Bar Foo ('b',2); -Foo->Bar(qw/c 3/); -Bar Foo (qw/d 4/); -Foo::->Bar('A',1); -Bar Foo:: ('B',2); -Foo::->Bar(qw/C 3/); -Bar Foo:: (qw/D 4/); -EXPECT -Foo a 1 -Foo b 2 -Foo c 3 -Foo d 4 -Foo A 1 -Foo B 2 -Foo C 3 -Foo D 4 diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars deleted file mode 100644 index 40b5557..0000000 --- a/contrib/perl5/t/pragma/strict-vars +++ /dev/null @@ -1,410 +0,0 @@ -Check strict vars functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(subs refs) ; -$fred ; -EXPECT - -######## - -use strict ; -no strict 'vars' ; -$fred ; -EXPECT - -######## - -# strict vars - no error -use strict 'vars' ; -use vars qw( $freddy) ; -BEGIN { *freddy = \$joe::shmoe; } -$freddy = 2 ; -EXPECT - -######## - -# strict vars - no error -use strict 'vars' ; -use vars qw( $freddy) ; -local $abc::joe ; -my $fred ; -my $b = \$fred ; -$Fred::ABC = 1 ; -$freddy = 2 ; -EXPECT - -######## - -# strict vars - error -use strict ; -$fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -<$fred> ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -local $fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -$joe = 1 ; -1; ---FILE-- -use strict 'vars' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -1; ---FILE-- -require "./abc"; -$joe = 1 ; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -require "./abc"; -EXPECT -Variable "$joe" is not imported at ./abc line 2. -Global symbol "$joe" requires explicit package name at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -use abc; -EXPECT -Variable "$joe" is not imported at abc.pm line 2. -Global symbol "$joe" requires explicit package name at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - ---FILE-- abc.pm -package Burp; -use strict; -$a = 1;$f = 1;$k = 1; # just to get beyond the limit... -$b = 1;$g = 1;$l = 1; -$c = 1;$h = 1;$m = 1; -$d = 1;$i = 1;$n = 1; -$e = 1;$j = 1;$o = 1; -$p = 0b12; ---FILE-- -use abc; -EXPECT -Global symbol "$f" requires explicit package name at abc.pm line 3. -Global symbol "$k" requires explicit package name at abc.pm line 3. -Global symbol "$g" requires explicit package name at abc.pm line 4. -Global symbol "$l" requires explicit package name at abc.pm line 4. -Global symbol "$c" requires explicit package name at abc.pm line 5. -Global symbol "$h" requires explicit package name at abc.pm line 5. -Global symbol "$m" requires explicit package name at abc.pm line 5. -Global symbol "$d" requires explicit package name at abc.pm line 6. -Global symbol "$i" requires explicit package name at abc.pm line 6. -Global symbol "$n" requires explicit package name at abc.pm line 6. -Global symbol "$e" requires explicit package name at abc.pm line 7. -Global symbol "$j" requires explicit package name at abc.pm line 7. -Global symbol "$o" requires explicit package name at abc.pm line 7. -Global symbol "$p" requires explicit package name at abc.pm line 8. -Illegal binary digit '2' at abc.pm line 8, at end of line -abc.pm has too many errors. -Compilation failed in require at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## - -# Check scope of pragma with eval -no strict ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'vars' ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 5. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - no strict ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 9. -Global symbol "$joe" requires explicit package name at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'vars' ; - $joe = 1 ; -]; print STDERR $@; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - no strict ; - $joe = 1 ; -'; print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check if multiple evals produce same errors -use strict 'vars'; -my $ret = eval q{ print $x; }; -print $@; -print "ok 1\n" unless defined $ret; -$ret = eval q{ print $x; }; -print $@; -print "ok 2\n" unless defined $ret; -EXPECT -Global symbol "$x" requires explicit package name at (eval 1) line 1. -ok 1 -Global symbol "$x" requires explicit package name at (eval 2) line 1. -ok 2 -######## - -# strict vars with outer our - no error -use strict 'vars' ; -our $freddy; -local $abc::joe ; -my $fred ; -my $b = \$fred ; -$Fred::ABC = 1 ; -$freddy = 2 ; -EXPECT - -######## - -# strict vars with inner our - no error -use strict 'vars' ; -sub foo { - our $fred; - $fred; -} -EXPECT - -######## - -# strict vars with outer our, inner use - no error -use strict 'vars' ; -our $fred; -sub foo { - $fred; -} -EXPECT - -######## - -# strict vars with nested our - no error -use strict 'vars' ; -our $fred; -sub foo { - our $fred; - $fred; -} -$fred ; -EXPECT - -######## - -# strict vars with elapsed our - error -use strict 'vars' ; -sub foo { - our $fred; - $fred; -} -$fred ; -EXPECT -Variable "$fred" is not imported at - line 8. -Global symbol "$fred" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# nested our with local - no error -$fred = 1; -use strict 'vars'; -{ - local our $fred = 2; - print $fred,"\n"; -} -print our $fred,"\n"; -EXPECT -2 -1 -######## - -# "nailed" our declaration visibility across package boundaries -use strict 'vars'; -our $foo; -$foo = 20; -package Foo; -print $foo, "\n"; -EXPECT -20 -######## - -# multiple our declarations in same scope, different packages, no warning -use strict 'vars'; -use warnings; -our $foo; -${foo} = 10; -package Foo; -our $foo = 20; -print $foo, "\n"; -EXPECT -20 -######## - -# multiple our declarations in same scope, same package, warning -use strict 'vars'; -use warnings; -our $foo; -${foo} = 10; -our $foo; -EXPECT -"our" variable $foo masks earlier declaration in same scope at - line 7. -######## - -# multiple our declarations in same scope, same package, warning -use strict 'vars'; -use warnings; -{ our $x = 1 } -{ our $x = 0 } -our $foo; -{ - our $foo; - package Foo; - our $foo; -} -EXPECT -"our" variable $foo redeclared at - line 9. - (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 11. -######## - -# Make sure the strict vars failure still occurs -# now that the `@i should be written as \@i' failure does not occur -# 20000522 mjd@plover.com (MJD) -use strict 'vars'; -no warnings; -"@i_like_crackers"; -EXPECT -Global symbol "@i_like_crackers" requires explicit package name at - line 7. -Execution of - aborted due to compilation errors. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t deleted file mode 100755 index 5b245d0..0000000 --- a/contrib/perl5/t/pragma/strict.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } - -my @prgs = () ; - -foreach (sort glob("pragma/strict-*")) { - - next if /(~|\.orig|,v)$/; - - open F, "<$_" or die "Cannot open $_: $!\n" ; - while (<F>) { - last if /^__END__/ ; - } - - { - local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; - } - close F ; -} - -undef $/; - -print "1..", scalar @prgs, "\n"; - - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_MSWin32 ? - `.\\perl -I../lib $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 - $expected =~ s/\n+$//; - my $prefix = ($results =~ s/^PREFIX\n//) ; - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t deleted file mode 100755 index f19268b..0000000 --- a/contrib/perl5/t/pragma/sub_lval.t +++ /dev/null @@ -1,542 +0,0 @@ -print "1..64\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary -sub b : lvalue { ${\shift} } - -my $out = a(b()); # Check that temporaries are allowed. -print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. -print "ok 1\n"; - -my @out = grep /main/, a(b()); # Check that temporaries are allowed. -print "# `@out'\nnot " unless @out==1; # Not reached if error. -print "ok 2\n"; - -my $in; - -# Check that we can return localized values from subroutines: - -sub in : lvalue { $in = shift; } -sub neg : lvalue { #(num_str) return num_str - local $_ = shift; - s/^\+/-/; - $_; -} -in(neg("+2")); - - -print "# `$in'\nnot " unless $in eq '-2'; -print "ok 3\n"; - -sub get_lex : lvalue { $in } -sub get_st : lvalue { $blah } -sub id : lvalue { ${\shift} } -sub id1 : lvalue { $_[0] } -sub inc : lvalue { ${\++$_[0]} } - -$in = 5; -$blah = 3; - -get_st = 7; - -print "# `$blah' ne 7\nnot " unless $blah eq 7; -print "ok 4\n"; - -get_lex = 7; - -print "# `$in' ne 7\nnot " unless $in eq 7; -print "ok 5\n"; - -++get_st; - -print "# `$blah' ne 8\nnot " unless $blah eq 8; -print "ok 6\n"; - -++get_lex; - -print "# `$in' ne 8\nnot " unless $in eq 8; -print "ok 7\n"; - -id(get_st) = 10; - -print "# `$blah' ne 10\nnot " unless $blah eq 10; -print "ok 8\n"; - -id(get_lex) = 10; - -print "# `$in' ne 10\nnot " unless $in eq 10; -print "ok 9\n"; - -++id(get_st); - -print "# `$blah' ne 11\nnot " unless $blah eq 11; -print "ok 10\n"; - -++id(get_lex); - -print "# `$in' ne 11\nnot " unless $in eq 11; -print "ok 11\n"; - -id1(get_st) = 20; - -print "# `$blah' ne 20\nnot " unless $blah eq 20; -print "ok 12\n"; - -id1(get_lex) = 20; - -print "# `$in' ne 20\nnot " unless $in eq 20; -print "ok 13\n"; - -++id1(get_st); - -print "# `$blah' ne 21\nnot " unless $blah eq 21; -print "ok 14\n"; - -++id1(get_lex); - -print "# `$in' ne 21\nnot " unless $in eq 21; -print "ok 15\n"; - -inc(get_st); - -print "# `$blah' ne 22\nnot " unless $blah eq 22; -print "ok 16\n"; - -inc(get_lex); - -print "# `$in' ne 22\nnot " unless $in eq 22; -print "ok 17\n"; - -inc(id(get_st)); - -print "# `$blah' ne 23\nnot " unless $blah eq 23; -print "ok 18\n"; - -inc(id(get_lex)); - -print "# `$in' ne 23\nnot " unless $in eq 23; -print "ok 19\n"; - -++inc(id1(id(get_st))); - -print "# `$blah' ne 25\nnot " unless $blah eq 25; -print "ok 20\n"; - -++inc(id1(id(get_lex))); - -print "# `$in' ne 25\nnot " unless $in eq 25; -print "ok 21\n"; - -@a = (1) x 3; -@b = (undef) x 2; -$#c = 3; # These slots are not fillable. - -# Explanation: empty slots contain &sv_undef. - -=for disabled constructs - -sub a3 :lvalue {@a} -sub b2 : lvalue {@b} -sub c4: lvalue {@c} - -$_ = ''; - -eval <<'EOE' or $_ = $@; - ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); - 1; -EOE - -#@out = ($x, a3, $y, b2, $z, c4, $t); -#@in = (34 .. 41, (undef) x 4, 46); -#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in"; - -print "# '$_'.\nnot " - unless /Can\'t return an uninitialized value from lvalue subroutine/; -=cut - -print "ok 22\n"; - -my $var; - -sub a::var : lvalue { $var } - -"a"->var = 45; - -print "# `$var' ne 45\nnot " unless $var eq 45; -print "ok 23\n"; - -my $oo; -$o = bless \$oo, "a"; - -$o->var = 47; - -print "# `$var' ne 47\nnot " unless $var eq 47; -print "ok 24\n"; - -sub o : lvalue { $o } - -o->var = 49; - -print "# `$var' ne 49\nnot " unless $var eq 49; -print "ok 25\n"; - -sub nolv () { $x0, $x1 } # Not lvalue - -$_ = ''; - -eval <<'EOE' or $_ = $@; - nolv = (2,3); - 1; -EOE - -print "not " - unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; -print "ok 26\n"; - -$_ = ''; - -eval <<'EOE' or $_ = $@; - nolv = (2,3) if $_; - 1; -EOE - -print "not " - unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; -print "ok 27\n"; - -$_ = ''; - -eval <<'EOE' or $_ = $@; - &nolv = (2,3) if $_; - 1; -EOE - -print "not " - unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; -print "ok 28\n"; - -$x0 = $x1 = $_ = undef; -$nolv = \&nolv; - -eval <<'EOE' or $_ = $@; - $nolv->() = (2,3) if $_; - 1; -EOE - -print "# '$_', '$x0', '$x1'.\nnot " if defined $_; -print "ok 29\n"; - -$x0 = $x1 = $_ = undef; -$nolv = \&nolv; - -eval <<'EOE' or $_ = $@; - $nolv->() = (2,3); - 1; -EOE - -print "# '$_', '$x0', '$x1'.\nnot " - unless /Can\'t modify non-lvalue subroutine call/; -print "ok 30\n"; - -sub lv0 : lvalue { } # Converted to lv10 in scalar context - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv0 = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t return a readonly value from lvalue subroutine/; -print "ok 31\n"; - -sub lv10 : lvalue {} - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv0) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " if defined $_; -print "ok 32\n"; - -sub lv1u :lvalue { undef } - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv1u = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t return a readonly value from lvalue subroutine/; -print "ok 33\n"; - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1u) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t return an uninitialized value from lvalue subroutine/; -print "ok 34\n"; - -$x = '1234567'; - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1t : lvalue { index $x, 2 } - lv1t = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify index in lvalue subroutine return/; -print "ok 35\n"; - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv2t : lvalue { shift } - (lv2t) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify shift in lvalue subroutine return/; -print "ok 36\n"; - -$xxx = 'xxx'; -sub xxx () { $xxx } # Not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmp : lvalue { xxx } # is it a TEMP? - lv1tmp = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; -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 yyy () { 'yyy' } # Const, not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmpr : lvalue { yyy } # is it read-only? - lv1tmpr = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify constant item in lvalue subroutine return/; -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"; - -sub lva : lvalue {@a} - -$_ = undef; -@a = (); -$a[1] = 12; -eval <<'EOE' or $_ = $@; - (lva) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; -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"; - -sub lv1n : lvalue { $newvar } - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv1n = (3,4); - 1; -EOE - -print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; -print "ok 44\n"; - -sub lv1nn : lvalue { $nnewvar } - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1nn) = (3,4); - 1; -EOE - -print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; -print "ok 45\n"; - -$a = \&lv1nn; -$a->() = 8; -print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; -print "ok 46\n"; - -# This must happen at run time -eval { - sub AUTOLOAD : lvalue { $newvar }; -}; -foobar() = 12; -print "# '$newvar'.\nnot " unless $newvar eq "12"; -print "ok 47\n"; - -# Testing DWIM of foo = bar; -sub foo : lvalue { - $a; -} -$a = "not ok 48\n"; -foo = "ok 48\n"; -print $a; - -open bar, ">nothing" or die $!; -bar = *STDOUT; -print bar "ok 49\n"; -unlink "nothing"; - -{ -my %hash; my @array; -sub alv : lvalue { $array[1] } -sub alv2 : lvalue { $array[$_[0]] } -sub hlv : lvalue { $hash{"foo"} } -sub hlv2 : lvalue { $hash{$_[0]} } -$array[1] = "not ok 51\n"; -alv() = "ok 50\n"; -print alv(); - -alv2(20) = "ok 51\n"; -print $array[20]; - -$hash{"foo"} = "not ok 52\n"; -hlv() = "ok 52\n"; -print $hash{foo}; - -$hash{bar} = "not ok 53\n"; -hlv("bar") = "ok 53\n"; -print hlv("bar"); - -sub array : lvalue { @array } -sub array2 : lvalue { @array2 } # This is a global. -sub hash : lvalue { %hash } -sub hash2 : lvalue { %hash2 } # So's this. -@array2 = qw(foo bar); -%hash2 = qw(foo bar); - -(array()) = qw(ok 54); -print "not " unless "@array" eq "ok 54"; -print "ok 54\n"; - -(array2()) = qw(ok 55); -print "not " unless "@array2" eq "ok 55"; -print "ok 55\n"; - -(hash()) = qw(ok 56); -print "not " unless $hash{ok} == 56; -print "ok 56\n"; - -(hash2()) = qw(ok 57); -print "not " unless $hash2{ok} == 57; -print "ok 57\n"; - -@array = qw(a b c d); -sub aslice1 : lvalue { @array[0,2] }; -(aslice1()) = ("ok", "already"); -print "# @array\nnot " unless "@array" eq "ok b already d"; -print "ok 58\n"; - -@array2 = qw(a B c d); -sub aslice2 : lvalue { @array2[0,2] }; -(aslice2()) = ("ok", "already"); -print "not " unless "@array2" eq "ok B already d"; -print "ok 59\n"; - -%hash = qw(a Alpha b Beta c Gamma); -sub hslice : lvalue { @hash{"c", "b"} } -(hslice()) = ("CISC", "BogoMIPS"); -print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; -print "ok 60\n"; -} - -$str = "Hello, world!"; -sub sstr : lvalue { substr($str, 1, 4) } -sstr() = "i"; -print "not " unless $str eq "Hi, world!"; -print "ok 61\n"; - -$str = "Made w/ JavaScript"; -sub veclv : lvalue { vec($str, 2, 32) } -if (ord('A') != 193) { - veclv() = 0x5065726C; -} -else { # EBCDIC? - veclv() = 0xD7859993; -} -print "# $str\nnot " unless $str eq "Made w/ PerlScript"; -print "ok 62\n"; - -sub position : lvalue { pos } -@p = (); -$_ = "fee fi fo fum"; -while (/f/g) { - push @p, position; - position() += 6; -} -print "# @p\nnot " unless "@p" eq "1 8"; -print "ok 63\n"; - -# Bug 20001223.002: split thought that the list had only one element -@ary = qw(4 5 6); -sub lval1 : lvalue { $ary[0]; } -sub lval2 : lvalue { $ary[1]; } -(lval1(), lval2()) = split ' ', "1 2 3 4"; -print "not " unless join(':', @ary) eq "1:2:6"; -print "ok 64\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t deleted file mode 100755 index 7e48e20..0000000 --- a/contrib/perl5/t/pragma/subs.t +++ /dev/null @@ -1,159 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; -undef $/; -my @prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile} } - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_VMS ? - `./perl $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $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//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} - -__END__ - -# Error - not predeclaring a sub -Fred 1,2 ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -Execution of - aborted due to compilation errors. -######## - -# Error - not predeclaring a sub in time -Fred 1,2 ; -use subs qw( Fred ) ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -BEGIN not safe after errors--compilation aborted at - line 4. -######## - -# AOK -use subs qw( Fred) ; -Fred 1,2 ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function -use subs qw( open ) ; -open 1,2 ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open 1,2 ; -EXPECT -3 -######## - -# override a built-in function, call with () -use subs qw( open ) ; -open (1,2) ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call with () after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open (1,2) ; -EXPECT -3 -######## - ---FILE-- abc -Fred 1,2 ; -1; ---FILE-- -use subs qw( Fred ) ; -require "./abc" ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# check that it isn't affected by block scope -{ - use subs qw( Fred ) ; -} -Fred 1, 2; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t deleted file mode 100755 index e0a321a..0000000 --- a/contrib/perl5/t/pragma/utf8.t +++ /dev/null @@ -1,462 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; - if ( ord("\t") != 9 ) { # skip on ebcdic platforms - print "1..0 # Skip utf8 tests on ebcdic platform.\n"; - exit; - } -} - -print "1..90\n"; - -my $test = 1; - -sub ok { - my ($got,$expect) = @_; - print "# expected [$expect], got [$got]\nnot " if $got ne $expect; - print "ok $test\n"; -} - -sub nok { - my ($got,$expect) = @_; - print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; - print "ok $test\n"; -} - -sub ok_bytes { - use bytes; - my ($got,$expect) = @_; - print "# expected [$expect], got [$got]\nnot " if $got ne $expect; - print "ok $test\n"; -} - -sub nok_bytes { - use bytes; - my ($got,$expect) = @_; - print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; - print "ok $test\n"; -} - -{ - use utf8; - $_ = ">\x{263A}<"; - s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 1 - - $_ = ">\x{263A}<"; - my $rx = "\x{80}-\x{10ffff}"; - s/([$rx])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 2 - - $_ = ">\x{263A}<"; - my $rx = "\\x{80}-\\x{10ffff}"; - s/([$rx])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 3 - - $_ = "alpha,numeric"; - m/([[:alpha:]]+)/; - ok $1, 'alpha'; - $test++; # 4 - - $_ = "alphaNUMERICstring"; - m/([[:^lower:]]+)/; - ok $1, 'NUMERIC'; - $test++; # 5 - - $_ = "alphaNUMERICstring"; - m/(\p{Ll}+)/; - ok $1, 'alpha'; - $test++; # 6 - - $_ = "alphaNUMERICstring"; - m/(\p{Lu}+)/; - ok $1, 'NUMERIC'; - $test++; # 7 - - $_ = "alpha,numeric"; - m/([\p{IsAlpha}]+)/; - ok $1, 'alpha'; - $test++; # 8 - - $_ = "alphaNUMERICstring"; - m/([^\p{IsLower}]+)/; - ok $1, 'NUMERIC'; - $test++; # 9 - - $_ = "alpha123numeric456"; - m/([\p{IsDigit}]+)/; - ok $1, '123'; - $test++; # 10 - - $_ = "alpha123numeric456"; - m/([^\p{IsDigit}]+)/; - ok $1, 'alpha'; - $test++; # 11 - - $_ = ",123alpha,456numeric"; - m/([\p{IsAlnum}]+)/; - ok $1, '123alpha'; - $test++; # 12 -} - -{ - use utf8; - - $_ = "\x{263A}>\x{263A}\x{263A}"; - - ok length, 4; - $test++; # 13 - - ok length((m/>(.)/)[0]), 1; - $test++; # 14 - - ok length($&), 2; - $test++; # 15 - - ok length($'), 1; - $test++; # 16 - - ok length($`), 1; - $test++; # 17 - - ok length($1), 1; - $test++; # 18 - - ok length($tmp=$&), 2; - $test++; # 19 - - ok length($tmp=$'), 1; - $test++; # 20 - - ok length($tmp=$`), 1; - $test++; # 21 - - ok length($tmp=$1), 1; - $test++; # 22 - - { - use bytes; - - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 23 - - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 24 - - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 25 - - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 26 - } - - ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 27 - - ok_bytes $', pack("C*", 0342, 0230, 0272); - $test++; # 28 - - ok_bytes $`, pack("C*", 0342, 0230, 0272); - $test++; # 29 - - ok_bytes $1, pack("C*", 0342, 0230, 0272); - $test++; # 30 - - { - use bytes; - no utf8; - - ok length, 10; - $test++; # 31 - - ok length((m/>(.)/)[0]), 1; - $test++; # 32 - - ok length($&), 2; - $test++; # 33 - - ok length($'), 5; - $test++; # 34 - - ok length($`), 3; - $test++; # 35 - - ok length($1), 1; - $test++; # 36 - - ok $&, pack("C*", ord(">"), 0342); - $test++; # 37 - - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 38 - - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 39 - - ok $1, pack("C*", 0342); - $test++; # 40 - } - - { - no utf8; - $_="\342\230\272>\342\230\272\342\230\272"; - } - - ok length, 10; - $test++; # 41 - - ok length((m/>(.)/)[0]), 1; - $test++; # 42 - - ok length($&), 2; - $test++; # 43 - - ok length($'), 1; - $test++; # 44 - - ok length($`), 1; - $test++; # 45 - - ok length($1), 1; - $test++; # 46 - - ok length($tmp=$&), 2; - $test++; # 47 - - ok length($tmp=$'), 1; - $test++; # 48 - - ok length($tmp=$`), 1; - $test++; # 49 - - ok length($tmp=$1), 1; - $test++; # 50 - - { - use bytes; - - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 51 - - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 52 - - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 53 - - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 54 - } - - { - use bytes; - no utf8; - - ok length, 10; - $test++; # 55 - - ok length((m/>(.)/)[0]), 1; - $test++; # 56 - - ok length($&), 2; - $test++; # 57 - - ok length($'), 5; - $test++; # 58 - - ok length($`), 3; - $test++; # 59 - - ok length($1), 1; - $test++; # 60 - - ok $&, pack("C*", ord(">"), 0342); - $test++; # 61 - - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 62 - - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 63 - - ok $1, pack("C*", 0342); - $test++; # 64 - } - - ok "\x{ab}" =~ /^\x{ab}$/, 1; - $test++; # 65 -} - -{ - use utf8; - ok join(" ",unpack("C*",chr(128).chr(255))), "128 255"; - $test++; -} - -{ - use utf8; - my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); - ok "@a", "1234 123 2345"; - $test++; # 67 -} - -{ - use utf8; - my $x = chr(123); - my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); - ok "@a", "1234 2345"; - $test++; # 68 -} - -{ - # bug id 20001009.001 - - my ($a, $b); - - { use bytes; $a = "\xc3\xa4" } - { use utf8; $b = "\xe4" } # \xXX must not produce UTF-8 - - print "not " if $a eq $b; - print "ok $test\n"; $test++; - - { use utf8; print "not " if $a eq $b; } - print "ok $test\n"; $test++; -} - -{ - # bug id 20001008.001 - - my @x = ("stra\337e 138","stra\337e 138"); - for (@x) { - s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; - my($latin) = /^(.+)(?:\s+\d)/; - print $latin eq "stra\337e" ? "ok $test\n" : - "#latin[$latin]\nnot ok $test\n"; - $test++; - $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a - use utf8; - $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a - } -} - -{ - # bug id 20000427.003 - - use utf8; - use warnings; - use strict; - - my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; - - my @charlist = split //, $sushi; - my $r = ''; - foreach my $ch (@charlist) { - $r = $r . " " . sprintf "U+%04X", ord($ch); - } - - print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000426.003 - - use utf8; - - my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; - - my ($a, $b, $c) = split(/\x40/, $s); - print "not " - unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x{100}/, $s); - print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); - print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x40\x{80}/, $s); - print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); - print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000730.004 - - use utf8; - - my $smiley = "\x{263a}"; - - for my $s ("\x{263a}", # 1 - $smiley, # 2 - - "" . $smiley, # 3 - "" . "\x{263a}", # 4 - - $smiley . "", # 5 - "\x{263a}" . "", # 6 - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - print "not " - unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "1/1/1/3"; - print "ok $test\n"; - $test++; - } - - for my $s ("\x{263a}" . "\x{263a}", # 7 - $smiley . $smiley, # 8 - - "\x{263a}\x{263a}", # 9 - "$smiley$smiley", # 10 - - "\x{263a}" x 2, # 11 - $smiley x 2, # 12 - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - print "not " - unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "2/2/2/6"; - print "ok $test\n"; - $test++; - } -} diff --git a/contrib/perl5/t/pragma/warn/1global b/contrib/perl5/t/pragma/warn/1global deleted file mode 100644 index 0af8022..0000000 --- a/contrib/perl5/t/pragma/warn/1global +++ /dev/null @@ -1,189 +0,0 @@ -Check existing $^W functionality - - -__END__ - -# warnable code, warnings disabled -$a =+ 3 ; -EXPECT - -######## --w -# warnable code, warnings enabled via command line switch -$a =+ 3 ; -EXPECT -Reversed += operator at - line 3. -Name "main::a" used only once: possible typo at - line 3. -######## -#! perl -w -# warnable code, warnings enabled via #! line -$a =+ 3 ; -EXPECT -Reversed += operator at - line 3. -Name "main::a" used only once: possible typo at - line 3. -######## - -# warnable code, warnings enabled via compile time $^W -BEGIN { $^W = 1 } -$a =+ 3 ; -EXPECT -Reversed += operator at - line 4. -Name "main::a" used only once: possible typo at - line 4. -######## - -# compile-time warnable code, warnings enabled via runtime $^W -# so no warning printed. -$^W = 1 ; -$a =+ 3 ; -EXPECT - -######## - -# warnable code, warnings enabled via runtime $^W -$^W = 1 ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -# warnings enabled at compile time, disabled at run time -BEGIN { $^W = 1 } -$^W = 0 ; -my $b ; chop $b ; -EXPECT - -######## - -# warnings disabled at compile time, enabled at run time -BEGIN { $^W = 0 } -$^W = 1 ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## --w ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -#! perl -w -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -$^W =1 ; -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -$^W = 0; -my $b ; chop $b ; -1 ; ---FILE-- -$^W =1 ; -require "./abcd"; -EXPECT - -######## - ---FILE-- abcd -$^W = 1; -1 ; ---FILE-- -$^W =0 ; -require "./abcd"; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 3. -######## - -$^W = 1; -eval 'my $b ; chop $b ;' ; -print $@ ; -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 1. -######## - -eval '$^W = 1;' ; -print $@ ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -eval {$^W = 1;} ; -print $@ ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -{ - local ($^W) = 1; -} -my $b ; chop $b ; -EXPECT - -######## - -my $a ; chop $a ; -{ - local ($^W) = 1; - my $b ; chop $b ; -} -my $c ; chop $c ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## --w --e undef -EXPECT -Use of uninitialized value in -e at - line 2. -######## - -$^W = 1 + 2 ; -EXPECT - -######## - -$^W = $a ; -EXPECT - -######## - -sub fred {} -$^W = fred() ; -EXPECT - -######## - -sub fred { my $b ; chop $b ;} -{ local $^W = 0 ; - fred() ; -} -EXPECT - -######## - -sub fred { my $b ; chop $b ;} -{ local $^W = 1 ; - fred() ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 2. diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use deleted file mode 100644 index b489d62..0000000 --- a/contrib/perl5/t/pragma/warn/2use +++ /dev/null @@ -1,356 +0,0 @@ -Check lexical warnings functionality - -TODO - check that the warning hierarchy works. - -__END__ - -# check illegal category is caught -use warnings 'this-should-never-be-a-warning-category' ; -EXPECT -unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 -BEGIN failed--compilation aborted at - line 3. -######## - -# Check compile time scope of pragma -use warnings 'deprecated' ; -{ - no warnings ; - 1 if $a EQ $b ; -} -1 if $a EQ $b ; -EXPECT -Use of EQ is deprecated at - line 8. -######## - -# Check compile time scope of pragma -no warnings; -{ - use warnings 'deprecated' ; - 1 if $a EQ $b ; -} -1 if $a EQ $b ; -EXPECT -Use of EQ is deprecated at - line 6. -######## - -# Check runtime scope of pragma -use warnings 'uninitialized' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings 'uninitialized' ; - my $b ; chop $b ; -} -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings 'uninitialized' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -use warnings 'deprecated' ; -1 if $a EQ $b ; -EXPECT -Use of EQ is deprecated at - line 3. -######## - ---FILE-- abc -1 if $a EQ $b ; -1; ---FILE-- -use warnings 'deprecated' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use warnings 'deprecated' ; -1; ---FILE-- -require "./abc"; -1 if $a EQ $b ; -EXPECT - -######## - ---FILE-- abc -use warnings 'deprecated' ; -1 if $a EQ $b ; -1; ---FILE-- -use warnings 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - ---FILE-- abc.pm -use warnings 'deprecated' ; -1 if $a EQ $b ; -1; ---FILE-- -use warnings 'uninitialized' ; -use abc; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - use warnings 'uninitialized' ; - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 7. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval { - no warnings ; - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - 1 if $a EQ $b ; - }; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - 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 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval { - 1 if $a EQ $b ; - }; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 7. -Use of EQ is deprecated at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval { - no warnings ; - 1 if $a EQ $b ; - }; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; - ]; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 9. -Use of EQ is deprecated at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - no warnings ; - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 10. -######## - -# Check the additive nature of the pragma -1 if $a EQ $b ; -my $a ; chop $a ; -use warnings 'deprecated' ; -1 if $a EQ $b ; -my $b ; chop $b ; -use warnings 'uninitialized' ; -my $c ; chop $c ; -no warnings 'deprecated' ; -1 if $a EQ $b ; -EXPECT -Use of EQ is deprecated at - line 6. -Use of uninitialized value in scalar chop at - line 9. -Use of uninitialized value in string eq at - line 11. -Use of uninitialized value in string eq at - line 11. diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both deleted file mode 100644 index 335e1b2..0000000 --- a/contrib/perl5/t/pragma/warn/3both +++ /dev/null @@ -1,266 +0,0 @@ -Check interaction of $^W and lexical - -__END__ - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -{ local $^W = 0 ; - fred() ; -} - -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -{ $^W = 0 ; - fred() ; -} - -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -{ local $^W = 1 ; - fred() ; -} - -EXPECT - -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -{ $^W = 1 ; - fred() ; -} - -EXPECT - -######## - -# Check interaction of $^W and use warnings -use warnings ; -$^W = 1 ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -$^W = 1 ; -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -$^W = 1 ; -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -no warnings ; -$^W = 1 ; -my $b ; -chop $b ; -EXPECT - -######## --w -# Check interaction of $^W and use warnings -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## --w -# Check interaction of $^W and use warnings -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -BEGIN { $^W = 0 } -fred() ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -BEGIN { $^W = 1 } -fred() ; - -EXPECT - -######## - -# Check interaction of $^W and use warnings -use warnings ; -BEGIN { $^W = 1 } -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -no warnings ; -BEGIN { $^W = 1 } -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -{ - no warnings ; - my $b ; - chop $b ; -} -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 0 } -{ - use warnings ; - my $b ; - chop $b ; -} -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 0 } -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 0 } -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint deleted file mode 100644 index b2fa75f..0000000 --- a/contrib/perl5/t/pragma/warn/4lint +++ /dev/null @@ -1,216 +0,0 @@ -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 STDIN at - line 6. -######## --W -# lint: check runtime $^W is zapped -$^W = 0 ; -close STDIN ; print STDIN "abc" ; -EXPECT -print() on closed filehandle STDIN at - line 4. -######## --W -# lint: check runtime $^W is zapped -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle 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 STDIN at - line 6. -######## --W -# lint: check "no warnings" is zapped -{ - no warnings ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --Ww -# lint: check combination of -w and -W -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --W ---FILE-- abc.pm -no warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; -1; ---FILE-- -no warnings 'uninitialized' ; -use abc; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc -no warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; -1; ---FILE-- -no warnings 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc.pm -BEGIN {$^W = 0} -my ($a, $b) = (0,0); -1 if $a EQ $b ; -1; ---FILE-- -$^W = 0 ; -use abc; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc -BEGIN {$^W = 0} -my ($a, $b) = (0,0); -1 if $a EQ $b ; -1; ---FILE-- -$^W = 0 ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W -# Check scope of pragma with eval -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 8. -######## --W -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## --W -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -use warnings; -{ - my $a = "1"; my $b = "2"; - no warnings ; - eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; - ]; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 11. -Use of EQ is deprecated at (eval 1) line 3. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 10. -Use of EQ is deprecated at (eval 1) line 2. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - use warnings 'deprecated' ; - eval ' - no warnings ; - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 11. -Use of EQ is deprecated at (eval 1) line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint deleted file mode 100644 index 2459968..0000000 --- a/contrib/perl5/t/pragma/warn/5nolint +++ /dev/null @@ -1,204 +0,0 @@ -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 -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; - ]; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - no warnings ; - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default deleted file mode 100644 index a8aafee..0000000 --- a/contrib/perl5/t/pragma/warn/6default +++ /dev/null @@ -1,121 +0,0 @@ -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. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings ; - my $a = oct "0xfffffffffffffffffg" ; - ]; print STDERR $@; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 3. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 2. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings; - eval ' - no warnings ; - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT - -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal deleted file mode 100644 index ed585c2..0000000 --- a/contrib/perl5/t/pragma/warn/7fatal +++ /dev/null @@ -1,312 +0,0 @@ -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 compile time warning -use warnings FATAL => 'all' ; -{ - no warnings ; - 1 if $a EQ $b ; -} -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at - line 8. -######## - -# Check runtime scope of pragma -use warnings FATAL => 'uninitialized' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -use warnings FATAL => 'all' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings FATAL => 'uninitialized' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings FATAL => 'all' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - ---FILE-- abc -1 if $a EQ $b ; -1; ---FILE-- -use warnings FATAL => 'deprecated' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use warnings FATAL => 'deprecated' ; -1; ---FILE-- -require "./abc"; -1 if $a EQ $b ; -EXPECT - -######## - ---FILE-- abc -use warnings 'deprecated' ; -1 if $a EQ $b ; -1; ---FILE-- -use warnings FATAL => 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - ---FILE-- abc.pm -use warnings 'deprecated' ; -1 if $a EQ $b ; -1; ---FILE-- -use warnings FATAL => 'uninitialized' ; -use abc; -my $a ; chop $a ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'uninitialized' ; - my $b ; chop $b ; -}; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at - line 6. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval { - my $b ; chop $b ; -}; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at - line 5. -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval { - no warnings ; - my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'deprecated' ; - 1 if $a EQ $b ; -}; print STDERR "-- $@" ; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at - line 6. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; -eval { - 1 if $a EQ $b ; -}; print STDERR "-- $@" ; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at - line 5. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; -eval { - no warnings ; - 1 if $a EQ $b ; -}; print STDERR $@ ; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'deprecated' ; -}; print STDERR $@ ; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -The End. -######## - -# Check scope of pragma with eval -no warnings ; -eval q[ - use warnings FATAL => 'uninitialized' ; - my $b ; chop $b ; -]; print STDERR "-- $@"; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at (eval 1) line 3. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval ' - my $b ; chop $b ; -'; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval ' - no warnings ; - my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval q[ - use warnings FATAL => 'deprecated' ; - 1 if $a EQ $b ; -]; print STDERR "-- $@"; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of EQ is deprecated at (eval 1) line 3. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; -eval ' - 1 if $a EQ $b ; -'; print STDERR "-- $@"; -print STDERR "The End.\n" ; -EXPECT --- Use of EQ is deprecated at (eval 1) line 2. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; -eval ' - no warnings ; - 1 if $a EQ $b ; -'; print STDERR "-- $@"; -1 if $a EQ $b ; -print STDERR "The End.\n" ; -EXPECT -Use of EQ is deprecated at - line 8. -######## - -use warnings 'void' ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. -######## - -use warnings ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. diff --git a/contrib/perl5/t/pragma/warn/8signal b/contrib/perl5/t/pragma/warn/8signal deleted file mode 100644 index d480f19..0000000 --- a/contrib/perl5/t/pragma/warn/8signal +++ /dev/null @@ -1,18 +0,0 @@ -Check interaction of __WARN__, __DIE__ & lexical Warnings - -TODO - -__END__ -# 8signal -BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } -BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } -1 if 1 EQ 2 ; -use warnings qw(deprecated) ; -1 if 1 EQ 2 ; -use warnings FATAL => qw(deprecated) ; -1 if 1 EQ 2 ; -print "The End.\n" ; -EXPECT -WARN -- Use of EQ is deprecated at - line 6. -DIE -- Use of EQ is deprecated at - line 8. -Use of EQ is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled deleted file mode 100755 index f5579b2..0000000 --- a/contrib/perl5/t/pragma/warn/9enabled +++ /dev/null @@ -1,1162 +0,0 @@ -Check warnings::enabled & warnings::warn - -__END__ - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("io") ; -1; ---FILE-- -no warnings; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -print "ok1\n" if !warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'syntax' ; -print "ok1\n" if warnings::enabled('io') ; -print "ok2\n" if ! warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'io' ; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -no warnings ; -print "ok1\n" if !warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -use warnings 'syntax' ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("syntax") ; -print "ok3\n" if warnings::enabled("io") ; -1; ---FILE-- -use warnings 'io' ; -require "abc" ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -abc::check() ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("io") ; -1; ---FILE-- def.pm -no warnings; -use abc ; -1; ---FILE-- -use warnings; -use def ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -print "ok3\n" if !warnings::enabled("io") ; -1; ---FILE-- def.pm -use warnings 'syntax' ; -print "ok4\n" if !warnings::enabled('all') ; -print "ok5\n" if warnings::enabled("io") ; -use abc ; -1; ---FILE-- -use warnings 'io' ; -use def ; -EXPECT -ok1 -ok2 -ok3 -ok4 -ok5 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; }; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -eval { use warnings 'io' ; abc::check() ; }; -abc::check() ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { no warnings ; abc::check() } -fred() ; -EXPECT -ok1 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; - print "ok4\n" if ! warnings::enabled("misc") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { use warnings 'io' ; abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -######## - -# check warnings::warn -use warnings ; -eval { warnings::warn() } ; -print $@ ; -eval { warnings::warn("fred", "joe") } ; -print $@ ; -EXPECT -Usage: warnings::warn([category,] 'message') at - line 4 -unknown warnings category 'fred' at - line 6 -######## - -# check warnings::warnif -use warnings ; -eval { warnings::warnif() } ; -print $@ ; -eval { warnings::warnif("fred", "joe") } ; -print $@ ; -EXPECT -Usage: warnings::warnif([category,] 'message') at - line 4 -unknown warnings category 'fred' at - line 6 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings "io" ; -use abc; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("misc", "hello") } -1; ---FILE-- -use warnings "io" ; -use abc; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings qw( FATAL deprecated ) ; -use abc; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -hello at - line 3 - eval {...} called at - line 3 -[[]] -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings qw( FATAL io ) ; -use abc; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -[[hello at - line 3 - eval {...} called at - line 3 -]] -######## --W ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if warnings::enabled("io") ; -print "ok2\n" if warnings::enabled("all") ; -1; ---FILE-- -no warnings; -use abc ; -EXPECT -ok1 -ok2 -######## --X ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if !warnings::enabled("io") ; -print "ok2\n" if !warnings::enabled("all") ; -1; ---FILE-- -use warnings; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok\n" if ! warnings::enabled() ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warn("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warnif("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -eval { abc::check() ; }; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -sub fred { abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if ! warnings::enabled ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { no warnings ; abc::check() } -fred() ; -EXPECT -ok1 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -use warnings::register; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; - print "ok4\n" if ! warnings::enabled("misc") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -sub fred { use warnings 'io' ; abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -use warnings::register; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings "abc" ; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings::register; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -abc::check() ; -EXPECT -hello at - line 2 -######## - ---FILE-- abc.pm -package abc ; -use warnings::register ; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings qw( FATAL deprecated ) ; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -hello at - line 3 - eval {...} called at - line 3 -[[]] -######## - ---FILE-- abc.pm -package abc ; -use warnings::register ; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings qw( FATAL abc ) ; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -[[hello at - line 3 - eval {...} called at - line 3 -]] -######## --W ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -no warnings; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## --X ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -no warnings; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -use warnings 'all'; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; - print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; - print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; -} -1; ---FILE-- def.pm -package def ; -use warnings "io" ; -use warnings::register ; -sub check { - print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; - print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ; - print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; -} -1; ---FILE-- -use abc ; -use def ; -use warnings 'abc'; -abc::check() ; -def::check() ; -no warnings 'abc' ; -use warnings 'def' ; -abc::check() ; -def::check() ; -use warnings 'abc' ; -use warnings 'def' ; -abc::check() ; -def::check() ; -no warnings 'abc' ; -no warnings 'def' ; -abc::check() ; -def::check() ; -use warnings; -abc::check() ; -def::check() ; -no warnings 'abc' ; -abc::check() ; -def::check() ; -EXPECT -abc self enabled -abc def not enabled -abc all not enabled -def self not enabled -def abc enabled -def all not enabled -abc self not enabled -abc def enabled -abc all not enabled -def self enabled -def abc not enabled -def all not enabled -abc self enabled -abc def enabled -abc all not enabled -def self enabled -def abc enabled -def all not enabled -abc self not enabled -abc def not enabled -abc all not enabled -def self not enabled -def abc not enabled -def all not enabled -abc self enabled -abc def enabled -abc all enabled -def self enabled -def abc enabled -def all enabled -abc self not enabled -abc def enabled -abc all not enabled -def self enabled -def abc not enabled -def all not enabled -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -BEGIN { $^W = 1 ; } -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -$^W = 1 ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -$| = 1; -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- -use abc ; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at - line 3 -my message 2 at - line 3 -my message 3 at - line 3 -######## - ---FILE-- def.pm -package def ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('def', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use def ; -use warnings 'def'; -sub in1 { def::in1() ; } -1; ---FILE-- -use abc ; -no warnings; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at abc.pm line 5 - abc::in1() called at - line 3 -my message 2 at abc.pm line 5 - abc::in1() called at - line 3 -my message 3 at abc.pm line 5 - abc::in1() called at - line 3 -######## - ---FILE-- def.pm -$| = 1; -package def ; -no warnings ; -use warnings::register ; -require Exporter; -@ISA = qw( Exporter ) ; -@EXPORT = qw( in1 ) ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('def', "my message 4") ; - warnings::warnif('io', "my message 5") ; - warnings::warnif('all', "my message 6") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -package abc ; -use warnings::register ; -use def ; -#@ISA = qw(def) ; -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 4 -my message 3 at - line 4 -######## - ---FILE-- def.pm -package def ; -no warnings ; -use warnings::register ; - -sub new -{ - my $class = shift ; - bless [], $class ; -} - -sub check -{ - my $self = shift ; - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - print "ok6\n" if warnings::enabled($self) ; - - warnings::warn("my message 1") ; - warnings::warn($self, "my message 2") ; - - warnings::warnif("my message 3") ; - warnings::warnif('abc', "my message 4") ; - warnings::warnif('def', "my message 5") ; - warnings::warnif('io', "my message 6") ; - warnings::warnif('all', "my message 7") ; - warnings::warnif($self, "my message 8") ; -} -sub in2 -{ - no warnings ; - my $self = shift ; - $self->check() ; -} -sub in1 -{ - no warnings ; - my $self = shift ; - $self->in2(); -} -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use warnings::register ; -use def ; -@ISA = qw(def) ; -sub new -{ - my $class = shift ; - bless [], $class ; -} - -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -$a = new abc ; -$a->in1() ; -print "**\n"; -$b = new def ; -$b->in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -ok5 -ok6 -my message 1 at - line 5 -my message 2 at - line 5 -my message 4 at - line 5 -my message 8 at - line 5 -** -ok1 -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 8 -my message 2 at - line 8 -my message 4 at - line 8 diff --git a/contrib/perl5/t/pragma/warn/av b/contrib/perl5/t/pragma/warn/av deleted file mode 100644 index 79bd3b76..0000000 --- a/contrib/perl5/t/pragma/warn/av +++ /dev/null @@ -1,9 +0,0 @@ - av.c - - Mandatory Warnings ALL TODO - ------------------ - av_reify called on tied array [av_reify] - - Attempt to clear deleted array [av_clear] - -__END__ diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio deleted file mode 100644 index 2a357e2..0000000 --- a/contrib/perl5/t/pragma/warn/doio +++ /dev/null @@ -1,209 +0,0 @@ - doio.c - - Can't open bidirectional pipe [Perl_do_open9] - open(F, "| true |"); - - Missing command in piped open [Perl_do_open9] - open(F, "| "); - - Missing command in piped open [Perl_do_open9] - open(F, " |"); - - warn(warn_nl, "open"); [Perl_do_open9] - open(F, "true\ncd") - - close() on unopened filehandle %s [Perl_do_close] - $a = "fred";close("$a") - - tell() on closed filehandle [Perl_do_tell] - $a = "fred";$a = tell($a) - - seek() on closed filehandle [Perl_do_seek] - $a = "fred";$a = seek($a,1,1) - - sysseek() on closed filehandle [Perl_do_sysseek] - $a = "fred";$a = seek($a,1,1) - - warn(warn_uninit); [Perl_do_print] - print $a ; - - -x on closed filehandle %s [Perl_my_stat] - close STDIN ; -x STDIN ; - - warn(warn_nl, "stat"); [Perl_my_stat] - stat "ab\ncd" - - warn(warn_nl, "lstat"); [Perl_my_lstat] - lstat "ab\ncd" - - Can't exec \"%s\": %s [Perl_do_aexec5] - - Can't exec \"%s\": %s [Perl_do_exec3] - - Filehandle %s opened only for output [Perl_do_eof] - my $a = eof STDOUT - - Mandatory Warnings ALL TODO - ------------------ - Can't do inplace edit: %s is not a regular file [Perl_nextargv] - edit a directory - - Can't do inplace edit: %s would not be unique [Perl_nextargv] - Can't rename %s to %s: %s, skipping file [Perl_nextargv] - Can't rename %s to %s: %s, skipping file [Perl_nextargv] - Can't remove %s: %s, skipping file [Perl_nextargv] - Can't do inplace edit on %s: %s [Perl_nextargv] - - -__END__ -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); -close(F); -no warnings 'io' ; -open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); -close(G); -EXPECT -Can't open bidirectional pipe at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, "| "); -no warnings 'io' ; -open(G, "| "); -EXPECT -Missing command in piped open at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, " |"); -no warnings 'io' ; -open(G, " |"); -EXPECT -Missing command in piped open at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, "<true\ncd"); -no warnings 'io' ; -open(G, "<true\ncd"); -EXPECT -Unsuccessful open on filename containing newline at - line 3. -######## -# doio.c [Perl_do_close] <<TODO -use warnings 'unopened' ; -close "fred" ; -no warnings 'unopened' ; -close "joe" ; -EXPECT -close() on unopened filehandle 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 ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; # ok -stat($a); # ok -no warnings 'io' ; -close STDIN ; -tell(STDIN); -$a = seek(STDIN,1,1); -$a = sysseek(STDIN,1,1); --x STDIN ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; -stat($a); -EXPECT -tell() on closed filehandle STDIN at - line 4. -seek() on closed filehandle STDIN at - line 5. -sysseek() on closed filehandle STDIN at - line 6. --x on closed filehandle STDIN at - line 7. -stat() on closed filehandle STDIN at - line 8. -tell() on unopened filehandle at - line 10. -seek() on unopened filehandle at - line 11. -sysseek() on unopened filehandle at - line 12. -######## -# doio.c [Perl_do_print] -use warnings 'uninitialized' ; -print $a ; -no warnings 'uninitialized' ; -print $b ; -EXPECT -Use of uninitialized value in print at - line 3. -######## -# doio.c [Perl_my_stat Perl_my_lstat] -use warnings 'io' ; -stat "ab\ncd"; -lstat "ab\ncd"; -no warnings 'io' ; -stat "ab\ncd"; -lstat "ab\ncd"; -EXPECT -Unsuccessful stat on filename containing newline at - line 3. -Unsuccessful stat on filename containing newline at - line 4. -######## -# doio.c [Perl_do_aexec5] -use warnings 'io' ; -exec "lskdjfalksdjfdjfkls","" ; -no warnings 'io' ; -exec "lskdjfalksdjfdjfkls","" ; -EXPECT -OPTION regex -Can't exec "lskdjfalksdjfdjfkls": .+ -######## -# doio.c [Perl_do_exec3] -use warnings 'io' ; -exec "lskdjfalksdjfdjfkls", "abc" ; -no warnings 'io' ; -exec "lskdjfalksdjfdjfkls", "abc" ; -EXPECT -OPTION regex -Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ -######## -# doio.c [Perl_nextargv] -$^W = 0 ; -my $filename = "./temp.dir" ; -mkdir $filename, 0777 - or die "Cannot create directory $filename: $!\n" ; -{ - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -{ - no warnings 'inplace' ; - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -{ - use warnings 'inplace' ; - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -rmdir $filename ; -EXPECT -Can't do inplace edit: ./temp.dir is not a regular file at - line 9. -Can't do inplace edit: ./temp.dir is not a regular file at - line 21. - -######## -# doio.c [Perl_do_eof] -use warnings 'io' ; -my $a = eof STDOUT ; -no warnings 'io' ; -$a = eof STDOUT ; -EXPECT -Filehandle STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/doop b/contrib/perl5/t/pragma/warn/doop deleted file mode 100644 index 5803b44..0000000 --- a/contrib/perl5/t/pragma/warn/doop +++ /dev/null @@ -1,6 +0,0 @@ -# doop.c -use utf8 ; -$_ = "\x80 \xff" ; -chop ; -EXPECT -######## diff --git a/contrib/perl5/t/pragma/warn/gv b/contrib/perl5/t/pragma/warn/gv deleted file mode 100644 index 5ed4eca..0000000 --- a/contrib/perl5/t/pragma/warn/gv +++ /dev/null @@ -1,54 +0,0 @@ - gv.c AOK - - Can't locate package %s for @%s::ISA - @ISA = qw(Fred); joe() - - Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated - sub Other::AUTOLOAD { 1 } sub Other::fred {} - @ISA = qw(Other) ; - fred() ; - - Use of $# is deprecated - Use of $* is deprecated - - $a = ${"#"} ; - $a = ${"*"} ; - - Mandatory Warnings ALL TODO - ------------------ - - Had to create %s unexpectedly [gv_fetchpv] - Attempt to free unreferenced glob pointers [gp_free] - -__END__ -# gv.c -use warnings 'misc' ; -@ISA = qw(Fred); joe() -EXPECT -Can't locate package Fred for @main::ISA at - line 3. -Undefined subroutine &main::joe called at - line 3. -######## -# gv.c -no warnings 'misc' ; -@ISA = qw(Fred); joe() -EXPECT -Undefined subroutine &main::joe called at - line 3. -######## -# gv.c -sub Other::AUTOLOAD { 1 } sub Other::fred {} -@ISA = qw(Other) ; -use warnings 'deprecated' ; -fred() ; -EXPECT -Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. -######## -# gv.c -use warnings 'deprecated' ; -$a = ${"#"}; -$a = ${"*"}; -no warnings 'deprecated' ; -$a = ${"#"}; -$a = ${"*"}; -EXPECT -Use of $# is deprecated at - line 3. -Use of $* is deprecated at - line 4. diff --git a/contrib/perl5/t/pragma/warn/hv b/contrib/perl5/t/pragma/warn/hv deleted file mode 100644 index c9eec02..0000000 --- a/contrib/perl5/t/pragma/warn/hv +++ /dev/null @@ -1,8 +0,0 @@ - hv.c - - - Mandatory Warnings ALL TODO - ------------------ - Attempt to free non-existent shared string [unsharepvn] - -__END__ diff --git a/contrib/perl5/t/pragma/warn/malloc b/contrib/perl5/t/pragma/warn/malloc deleted file mode 100644 index 2f8b096..0000000 --- a/contrib/perl5/t/pragma/warn/malloc +++ /dev/null @@ -1,9 +0,0 @@ - malloc.c - - - Mandatory Warnings ALL TODO - ------------------ - %s free() ignored [Perl_mfree] - %s", "Bad free() ignored [Perl_mfree] - -__END__ diff --git a/contrib/perl5/t/pragma/warn/mg b/contrib/perl5/t/pragma/warn/mg deleted file mode 100644 index a8f9dbc..0000000 --- a/contrib/perl5/t/pragma/warn/mg +++ /dev/null @@ -1,44 +0,0 @@ - mg.c AOK - - No such signal: SIG%s - $SIG{FRED} = sub {} - - SIG%s handler \"%s\" not defined. - $SIG{"INT"} = "ok3"; kill "INT",$$; - - Mandatory Warnings TODO - ------------------ - Can't break at that line [magic_setdbline] - -__END__ -# mg.c -use warnings 'signal' ; -$SIG{FRED} = sub {}; -EXPECT -No such signal: SIGFRED at - line 3. -######## -# mg.c -no warnings 'signal' ; -$SIG{FRED} = sub {}; -EXPECT - -######## -# mg.c -use warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'VMS') { - print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; -} -$|=1; -$SIG{"INT"} = "fred"; kill "INT",$$; -EXPECT -SIGINT handler "fred" not defined. -######## -# mg.c -no warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'VMS') { - print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; -} -$|=1; -$SIG{"INT"} = "fred"; kill "INT",$$; -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op deleted file mode 100644 index 1f41a98..0000000 --- a/contrib/perl5/t/pragma/warn/op +++ /dev/null @@ -1,872 +0,0 @@ - op.c AOK - - "my" variable %s masks earlier declaration in same scope - my $x; - my $x ; - - Variable "%s" may be unavailable - sub x { - my $x; - sub y { - $x - } - } - - Variable "%s" will not stay shared - sub x { - my $x; - sub y { - sub { $x } - } - } - - Found = in conditional, should be == - 1 if $a = 1 ; - - Use of implicit split to @_ is deprecated - split ; - - Use of implicit split to @_ is deprecated - $a = split ; - - Useless use of time in void context - Useless use of a variable in void context - Useless use of a constant in void context - time ; - $a ; - "abc" - - Applying %s to %s will act on scalar(%s) - my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; - @a =~ /abc/ ; - @a =~ s/a/b/ ; - @a =~ tr/a/b/ ; - @$b =~ /abc/ ; - @$b =~ s/a/b/ ; - @$b =~ tr/a/b/ ; - %a =~ /abc/ ; - %a =~ s/a/b/ ; - %a =~ tr/a/b/ ; - %$c =~ /abc/ ; - %$c =~ s/a/b/ ; - %$c =~ tr/a/b/ ; - - - Parentheses missing around "my" list at -e line 1. - my $a, $b = (1,2); - - Parentheses missing around "local" list at -e line 1. - local $a, $b = (1,2); - - Bareword found in conditional at -e line 1. - use warnings 'bareword'; my $x = print(ABC || 1); - - Value of %s may be \"0\"; use \"defined\" - $x = 1 if $x = <FH> ; - $x = 1 while $x = <FH> ; - - Subroutine fred redefined at -e line 1. - sub fred{1;} sub fred{1;} - - Constant subroutine %s redefined - sub fred() {1;} sub fred() {1;} - - Format FRED redefined at /tmp/x line 5. - format FRED = - . - format FRED = - . - - Array @%s missing the @ in argument %d of %s() - push fred ; - - Hash %%%s missing the %% in argument %d of %s() - keys joe ; - - Statement unlikely to be reached - (Maybe you meant system() when you said exec()? - exec "true" ; my $a - - defined(@array) is deprecated - (Maybe you should just omit the defined()?) - my @a ; defined @a ; - defined (@a = (1,2,3)) ; - - defined(%hash) is deprecated - (Maybe you should just omit the defined()?) - my %h ; defined %h ; - - /---/ should probably be written as "---" - join(/---/, @foo); - - %s() called too early to check prototype [Perl_peep] - fred() ; sub fred ($$) {} - - - Mandatory Warnings - ------------------ - Prototype mismatch: [cv_ckproto] - sub fred() ; - sub fred($) {} - - %s never introduced [pad_leavemy] TODO - Runaway prototype [newSUB] TODO - oops: oopsAV [oopsAV] TODO - oops: oopsHV [oopsHV] TODO - - -__END__ -# op.c -use warnings 'misc' ; -my $x ; -my $x ; -no warnings 'misc' ; -my $x ; -EXPECT -"my" variable $x masks earlier declaration in same scope at - line 4. -######## -# op.c -use warnings 'closure' ; -sub x { - my $x; - sub y { - $x - } - } -EXPECT -Variable "$x" will not stay shared at - line 7. -######## -# op.c -no warnings 'closure' ; -sub x { - my $x; - sub y { - $x - } - } -EXPECT - -######## -# op.c -use warnings 'closure' ; -sub x { - our $x; - sub y { - $x - } - } -EXPECT - -######## -# op.c -use warnings 'closure' ; -sub x { - my $x; - sub y { - sub { $x } - } - } -EXPECT -Variable "$x" may be unavailable at - line 6. -######## -# op.c -no warnings 'closure' ; -sub x { - my $x; - sub y { - sub { $x } - } - } -EXPECT - -######## -# op.c -use warnings 'syntax' ; -1 if $a = 1 ; -no warnings 'syntax' ; -1 if $a = 1 ; -EXPECT -Found = in conditional, should be == at - line 3. -######## -# op.c -use warnings 'deprecated' ; -split ; -no warnings 'deprecated' ; -split ; -EXPECT -Use of implicit split to @_ is deprecated at - line 3. -######## -# op.c -use warnings 'deprecated' ; -$a = split ; -no warnings 'deprecated' ; -$a = split ; -EXPECT -Use of implicit split to @_ is deprecated at - line 3. -######## -# op.c -use warnings 'void' ; close STDIN ; -1 x 3 ; # OP_REPEAT - # OP_GVSV -wantarray ; # OP_WANTARRAY - # OP_GV - # OP_PADSV - # OP_PADAV - # OP_PADHV - # OP_PADANY - # OP_AV2ARYLEN -ref ; # OP_REF -\@a ; # OP_REFGEN -\$a ; # OP_SREFGEN -defined $a ; # OP_DEFINED -hex $a ; # OP_HEX -oct $a ; # OP_OCT -length $a ; # OP_LENGTH -substr $a,1 ; # OP_SUBSTR -vec $a,1,2 ; # OP_VEC -index $a,1,2 ; # OP_INDEX -rindex $a,1,2 ; # OP_RINDEX -sprintf $a ; # OP_SPRINTF -$a[0] ; # OP_AELEM - # OP_AELEMFAST -@a[0] ; # OP_ASLICE -#values %a ; # OP_VALUES -#keys %a ; # OP_KEYS -$a{0} ; # OP_HELEM -@a{0} ; # OP_HSLICE -unpack "a", "a" ; # OP_UNPACK -pack $a,"" ; # OP_PACK -join "" ; # OP_JOIN -(@a)[0,1] ; # OP_LSLICE - # OP_ANONLIST - # OP_ANONHASH -sort(1,2) ; # OP_SORT -reverse(1,2) ; # OP_REVERSE - # OP_RANGE - # OP_FLIP -(1 ..2) ; # OP_FLOP -caller ; # OP_CALLER -fileno STDIN ; # OP_FILENO -eof STDIN ; # OP_EOF -tell STDIN ; # OP_TELL -readlink 1; # OP_READLINK -time ; # OP_TIME -localtime ; # OP_LOCALTIME -gmtime ; # OP_GMTIME -eval { getgrnam 1 }; # OP_GGRNAM -eval { getgrgid 1 }; # OP_GGRGID -eval { getpwnam 1 }; # OP_GPWNAM -eval { getpwuid 1 }; # OP_GPWUID -EXPECT -Useless use of repeat (x) in void context at - line 3. -Useless use of wantarray in void context at - line 5. -Useless use of reference-type operator in void context at - line 12. -Useless use of reference constructor in void context at - line 13. -Useless use of single ref constructor in void context at - line 14. -Useless use of defined operator in void context at - line 15. -Useless use of hex in void context at - line 16. -Useless use of oct in void context at - line 17. -Useless use of length in void context at - line 18. -Useless use of substr in void context at - line 19. -Useless use of vec in void context at - line 20. -Useless use of index in void context at - line 21. -Useless use of rindex in void context at - line 22. -Useless use of sprintf in void context at - line 23. -Useless use of array element in void context at - line 24. -Useless use of array slice in void context at - line 26. -Useless use of hash element in void context at - line 29. -Useless use of hash slice in void context at - line 30. -Useless use of unpack in void context at - line 31. -Useless use of pack in void context at - line 32. -Useless use of join or string in void context at - line 33. -Useless use of list slice in void context at - line 34. -Useless use of sort in void context at - line 37. -Useless use of reverse in void context at - line 38. -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 -# -use warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; -@a =~ /abc/ ; -@a =~ s/a/b/ ; -@a =~ tr/a/b/ ; -@$b =~ /abc/ ; -@$b =~ s/a/b/ ; -@$b =~ tr/a/b/ ; -%a =~ /abc/ ; -%a =~ s/a/b/ ; -%a =~ tr/a/b/ ; -%$c =~ /abc/ ; -%$c =~ s/a/b/ ; -%$c =~ tr/a/b/ ; -{ -no warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; -@a =~ /abc/ ; -@a =~ s/a/b/ ; -@a =~ tr/a/b/ ; -@$b =~ /abc/ ; -@$b =~ s/a/b/ ; -@$b =~ tr/a/b/ ; -%a =~ /abc/ ; -%a =~ s/a/b/ ; -%a =~ tr/a/b/ ; -%$c =~ /abc/ ; -%$c =~ s/a/b/ ; -%$c =~ tr/a/b/ ; -} -EXPECT -Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. -Applying substitution (s///) to @array will act on scalar(@array) at - line 6. -Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. -Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. -Applying substitution (s///) to @array will act on scalar(@array) at - line 9. -Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10. -Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11. -Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12. -Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13. -Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. -Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. -Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. -Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" -BEGIN not safe after errors--compilation aborted at - line 18. -######## -# op.c -use warnings 'syntax' ; -my $a, $b = (1,2); -no warnings 'syntax' ; -my $c, $d = (1,2); -EXPECT -Parentheses missing around "my" list at - line 3. -######## -# op.c -use warnings 'syntax' ; -local $a, $b = (1,2); -no warnings 'syntax' ; -local $c, $d = (1,2); -EXPECT -Parentheses missing around "local" list at - line 3. -######## -# op.c -use warnings 'bareword' ; -print (ABC || 1) ; -no warnings 'bareword' ; -print (ABC || 1) ; -EXPECT -Bareword found in conditional at - line 3. -######## ---FILE-- abc - ---FILE-- -# op.c -use warnings 'misc' ; -open FH, "<abc" ; -$x = 1 if $x = <FH> ; -no warnings 'misc' ; -$x = 1 if $x = <FH> ; -EXPECT -Value of <HANDLE> construct can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -opendir FH, "." ; -$x = 1 if $x = readdir FH ; -no warnings 'misc' ; -$x = 1 if $x = readdir FH ; -closedir FH ; -EXPECT -Value of readdir() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -$x = 1 if $x = <*> ; -no warnings 'misc' ; -$x = 1 if $x = <*> ; -EXPECT -Value of glob construct can be "0"; test with defined() at - line 3. -######## -# op.c -use warnings 'misc' ; -%a = (1,2,3,4) ; -$x = 1 if $x = each %a ; -no warnings 'misc' ; -$x = 1 if $x = each %a ; -EXPECT -Value of each() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -$x = 1 while $x = <*> and 0 ; -no warnings 'misc' ; -$x = 1 while $x = <*> and 0 ; -EXPECT -Value of glob construct can be "0"; test with defined() at - line 3. -######## -# op.c -use warnings 'misc' ; -opendir FH, "." ; -$x = 1 while $x = readdir FH and 0 ; -no warnings 'misc' ; -$x = 1 while $x = readdir FH and 0 ; -closedir FH ; -EXPECT -Value of readdir() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'redefine' ; -sub fred {} -sub fred {} -no warnings 'redefine' ; -sub fred {} -EXPECT -Subroutine fred redefined at - line 4. -######## -# op.c -use warnings 'redefine' ; -sub fred () { 1 } -sub fred () { 1 } -no warnings 'redefine' ; -sub fred () { 1 } -EXPECT -Constant subroutine fred redefined at - line 4. -######## -# op.c -use warnings 'redefine' ; -format FRED = -. -format FRED = -. -no warnings 'redefine' ; -format FRED = -. -EXPECT -Format FRED redefined at - line 5. -######## -# op.c -use warnings 'deprecated' ; -push FRED; -no warnings 'deprecated' ; -push FRED; -EXPECT -Array @FRED missing the @ in argument 1 of push() at - line 3. -######## -# op.c -use warnings 'deprecated' ; -@a = keys FRED ; -no warnings 'deprecated' ; -@a = keys FRED ; -EXPECT -Hash %FRED missing the % in argument 1 of keys() at - line 3. -######## -# op.c -use warnings 'syntax' ; -exec "$^X -e 1" ; -my $a -EXPECT -Statement unlikely to be reached at - line 4. - (Maybe you meant system() when you said exec()?) -######## -# op.c -use warnings 'deprecated' ; -my @a; defined(@a); -EXPECT -defined(@array) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -use warnings 'deprecated' ; -defined(@a = (1,2,3)); -EXPECT -defined(@array) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -use warnings 'deprecated' ; -my %h; defined(%h); -EXPECT -defined(%hash) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -no warnings 'syntax' ; -exec "$^X -e 1" ; -my $a -EXPECT - -######## -# op.c -sub fred(); -sub fred($) {} -EXPECT -Prototype mismatch: sub main::fred () vs ($) at - line 3. -######## -# op.c -$^W = 0 ; -sub fred() ; -sub fred($) {} -{ - no warnings 'prototype' ; - sub Fred() ; - sub Fred($) {} - use warnings 'prototype' ; - sub freD() ; - sub freD($) {} -} -sub FRED() ; -sub FRED($) {} -EXPECT -Prototype mismatch: sub main::fred () vs ($) at - line 4. -Prototype mismatch: sub main::freD () vs ($) at - line 11. -Prototype mismatch: sub main::FRED () vs ($) at - line 14. -######## -# op.c -use warnings 'syntax' ; -join /---/, 'x', 'y', 'z'; -EXPECT -/---/ should probably be written as "---" at - line 3. -######## -# op.c [Perl_peep] -use warnings 'prototype' ; -fred() ; -sub fred ($$) {} -no warnings 'prototype' ; -joe() ; -sub joe ($$) {} -EXPECT -main::fred() called too early to check prototype at - line 3. -######## -# op.c [Perl_newATTRSUB] ---FILE-- abc.pm -use warnings 'void' ; -BEGIN { $| = 1; print "in begin\n"; } -CHECK { print "in check\n"; } -INIT { print "in init\n"; } -END { print "in end\n"; } -print "in mainline\n"; -1; ---FILE-- -use abc; -delete $INC{"abc.pm"}; -require abc; -do "abc.pm"; -EXPECT -in begin -in mainline -in check -in init -in begin -Too late to run CHECK block at abc.pm line 3. -Too late to run INIT block at abc.pm line 4. -in mainline -in begin -Too late to run CHECK block at abc.pm line 3. -Too late to run INIT block at abc.pm line 4. -in mainline -in end -in end -in end -######## -# op.c [Perl_newATTRSUB] ---FILE-- abc.pm -no warnings 'void' ; -BEGIN { $| = 1; print "in begin\n"; } -CHECK { print "in check\n"; } -INIT { print "in init\n"; } -END { print "in end\n"; } -print "in mainline\n"; -1; ---FILE-- -require abc; -do "abc.pm"; -EXPECT -in begin -in mainline -in begin -in mainline -in end -in end diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl deleted file mode 100644 index b4a00ba..0000000 --- a/contrib/perl5/t/pragma/warn/perl +++ /dev/null @@ -1,72 +0,0 @@ - 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 -######## - -# perl.c -{ use warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::x" used only once: possible typo at - line 3. -######## - -# perl.c -$z = 3 ; -BEGIN { $^W = 1 } -{ no warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::y" used only once: possible typo at - line 6. diff --git a/contrib/perl5/t/pragma/warn/perlio b/contrib/perl5/t/pragma/warn/perlio deleted file mode 100644 index 18c0dfa..0000000 --- a/contrib/perl5/t/pragma/warn/perlio +++ /dev/null @@ -1,10 +0,0 @@ - perlio.c - - - Mandatory Warnings ALL TODO - ------------------ - Setting cnt to %d - Setting ptr %p > end+1 %p - Setting cnt to %d, ptr implies %d - -__END__ diff --git a/contrib/perl5/t/pragma/warn/perly b/contrib/perl5/t/pragma/warn/perly deleted file mode 100644 index afc5dcc..0000000 --- a/contrib/perl5/t/pragma/warn/perly +++ /dev/null @@ -1,31 +0,0 @@ - perly.y AOK - - dep() => deprecate("\"do\" to call subroutines") - Use of "do" to call subroutines is deprecated - - sub fred {} do fred() - sub fred {} do fred(1) - sub fred {} $a = "fred" ; do $a() - sub fred {} $a = "fred" ; do $a(1) - - -__END__ -# perly.y -use warnings 'deprecated' ; -sub fred {} -do fred() ; -do fred(1) ; -$a = "fred" ; -do $a() ; -do $a(1) ; -no warnings 'deprecated' ; -do fred() ; -do fred(1) ; -$a = "fred" ; -do $a() ; -do $a(1) ; -EXPECT -Use of "do" to call subroutines is deprecated at - line 4. -Use of "do" to call subroutines is deprecated at - line 5. -Use of "do" to call subroutines is deprecated at - line 7. -Use of "do" to call subroutines is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/pp b/contrib/perl5/t/pragma/warn/pp deleted file mode 100644 index 8f42ba6..0000000 --- a/contrib/perl5/t/pragma/warn/pp +++ /dev/null @@ -1,110 +0,0 @@ - pp.c TODO - - substr outside of string - $a = "ab" ; $b = substr($a, 4,5) ; - - Attempt to use reference as lvalue in substr - $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b - - uninitialized in pp_rv2gv() - my *b = *{ undef()} - - uninitialized in pp_rv2sv() - my $a = undef ; my $b = $$a - - Odd number of elements in hash list - my $a = { 1,2,3 } ; - - Invalid type in unpack: '%c - my $A = pack ("A,A", 1,2) ; - my @A = unpack ("A,A", "22") ; - - Attempt to pack pointer to temporary value - pack("p", "abc") ; - - Explicit blessing to '' (assuming package main) - bless \[], ""; - - Constant subroutine %s undefined <<<TODO - Constant subroutine (anonymous) undefined <<<TODO - -__END__ -# pp.c -use warnings 'substr' ; -$a = "ab" ; -$b = substr($a, 4,5) ; -no warnings 'substr' ; -$a = "ab" ; -$b = substr($a, 4,5) ; -EXPECT -substr outside of string at - line 4. -######## -# pp.c -use warnings 'substr' ; -$a = "ab" ; -$b = \$a ; -substr($b, 1,1) = "ab" ; -no warnings 'substr' ; -substr($b, 1,1) = "ab" ; -EXPECT -Attempt to use reference as lvalue in substr at - line 5. -######## -# pp.c -use warnings 'uninitialized' ; -# TODO -EXPECT - -######## -# pp.c -use warnings 'misc' ; -my $a = { 1,2,3}; -no warnings 'misc' ; -my $b = { 1,2,3}; -EXPECT -Odd number of elements in hash assignment at - line 3. -######## -# pp.c -use warnings 'pack' ; -use warnings 'unpack' ; -my @a = unpack ("A,A", "22") ; -my $a = pack ("A,A", 1,2) ; -no warnings 'pack' ; -no warnings 'unpack' ; -my @b = unpack ("A,A", "22") ; -my $b = pack ("A,A", 1,2) ; -EXPECT -Invalid type in unpack: ',' at - line 4. -Invalid type in pack: ',' at - line 5. -######## -# pp.c -use warnings 'uninitialized' ; -my $a = undef ; -my $b = $$a; -no warnings 'uninitialized' ; -my $c = $$a; -EXPECT -Use of uninitialized value in scalar dereference at - line 4. -######## -# pp.c -use warnings 'pack' ; -sub foo { my $a = "a"; return $a . $a++ . $a++ } -my $a = pack("p", &foo) ; -no warnings 'pack' ; -my $b = pack("p", &foo) ; -EXPECT -Attempt to pack pointer to temporary value at - line 4. -######## -# pp.c -use warnings 'misc' ; -bless \[], "" ; -no warnings 'misc' ; -bless \[], "" ; -EXPECT -Explicit blessing to '' (assuming package main) at - line 3. -######## -# pp.c -use utf8 ; -$_ = "\x80 \xff" ; -reverse ; -EXPECT -######## diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl deleted file mode 100644 index ac01f27..0000000 --- a/contrib/perl5/t/pragma/warn/pp_ctl +++ /dev/null @@ -1,230 +0,0 @@ - pp_ctl.c AOK - - Not enough format arguments - format STDOUT = - @<<< @<<< - $a - . - write; - - - Exiting substitution via %s - $_ = "abc" ; - while ($i ++ == 0) - { - s/ab/last/e ; - } - - Exiting subroutine via %s - sub fred { last } - { fred() } - - Exiting eval via %s - { eval "last" } - - Exiting pseudo-block via %s - @a = (1,2) ; @b = sort { last } @a ; - - Exiting substitution via %s - $_ = "abc" ; - last fred: - while ($i ++ == 0) - { - s/ab/last fred/e ; - } - - - Exiting subroutine via %s - sub fred { last joe } - joe: { fred() } - - Exiting eval via %s - fred: { eval "last fred" } - - Exiting pseudo-block via %s - @a = (1,2) ; fred: @b = sort { last fred } @a ; - - - Deep recursion on subroutine \"%s\" - sub fred - { - fred() if $a++ < 200 - } - - fred() - - (in cleanup) foo bar - package Foo; - DESTROY { die "foo bar" } - { bless [], 'Foo' for 1..10 } - -__END__ -# pp_ctl.c -use warnings 'syntax' ; -format STDOUT = -@<<< @<<< -1 -. -write; -EXPECT -Not enough format arguments at - line 5. -1 -######## -# pp_ctl.c -no warnings 'syntax' ; -format = -@<<< @<<< -1 -. -write ; -EXPECT -1 -######## -# pp_ctl.c -use warnings 'exiting' ; -$_ = "abc" ; - -while ($i ++ == 0) -{ - s/ab/last/e ; -} -no warnings 'exiting' ; -while ($i ++ == 0) -{ - s/ab/last/e ; -} -EXPECT -Exiting substitution via last at - line 7. -######## -# pp_ctl.c -use warnings 'exiting' ; -sub fred { last } -{ fred() } -no warnings 'exiting' ; -sub joe { last } -{ joe() } -EXPECT -Exiting subroutine via last at - line 3. -######## -# pp_ctl.c -{ - eval "use warnings 'exiting' ; last;" -} -print STDERR $@ ; -{ - eval "no warnings 'exiting' ;last;" -} -print STDERR $@ ; -EXPECT -Exiting eval via last at (eval 1) line 1. -######## -# pp_ctl.c -use warnings 'exiting' ; -@a = (1,2) ; -@b = sort { last } @a ; -no warnings 'exiting' ; -@b = sort { last } @a ; -EXPECT -Exiting pseudo-block via last at - line 4. -Can't "last" outside a loop block at - line 4. -######## -# pp_ctl.c -use warnings 'exiting' ; -$_ = "abc" ; -fred: -while ($i ++ == 0) -{ - s/ab/last fred/e ; -} -no warnings 'exiting' ; -while ($i ++ == 0) -{ - s/ab/last fred/e ; -} -EXPECT -Exiting substitution via last at - line 7. -######## -# pp_ctl.c -use warnings 'exiting' ; -sub fred { last joe } -joe: { fred() } -no warnings 'exiting' ; -sub Fred { last Joe } -Joe: { Fred() } -EXPECT -Exiting subroutine via last at - line 3. -######## -# pp_ctl.c -joe: -{ eval "use warnings 'exiting' ; last joe;" } -print STDERR $@ ; -Joe: -{ eval "no warnings 'exiting' ; last Joe;" } -print STDERR $@ ; -EXPECT -Exiting eval via last at (eval 1) line 1. -######## -# pp_ctl.c -use warnings 'exiting' ; -@a = (1,2) ; -fred: @b = sort { last fred } @a ; -no warnings 'exiting' ; -Fred: @b = sort { last Fred } @a ; -EXPECT -Exiting pseudo-block via last at - line 4. -Label not found for "last fred" at - line 4. -######## -# pp_ctl.c -use warnings 'recursion' ; -BEGIN { warn "PREFIX\n" ;} -sub fred -{ - fred() if $a++ < 200 -} - -fred() -EXPECT -Deep recursion on subroutine "main::fred" at - line 6. -######## -# pp_ctl.c -no warnings 'recursion' ; -BEGIN { warn "PREFIX\n" ;} -sub fred -{ - fred() if $a++ < 200 -} - -fred() -EXPECT -######## -# pp_ctl.c -use warnings 'misc' ; -package Foo; -DESTROY { die "@{$_[0]} foo bar" } -{ bless ['A'], 'Foo' for 1..10 } -{ bless ['B'], 'Foo' for 1..10 } -EXPECT - (in cleanup) A foo bar at - line 4. - (in cleanup) B foo bar at - line 4. -######## -# pp_ctl.c -no warnings 'misc' ; -package Foo; -DESTROY { die "@{$_[0]} foo bar" } -{ bless ['A'], 'Foo' for 1..10 } -{ bless ['B'], 'Foo' for 1..10 } -EXPECT -######## -# pp_ctl.c -use warnings; -eval 'print $foo'; -EXPECT -Use of uninitialized value in print at (eval 1) line 1. -######## -# pp_ctl.c -use warnings; -{ - no warnings; - eval 'print $foo'; -} -EXPECT diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot deleted file mode 100644 index 698255c..0000000 --- a/contrib/perl5/t/pragma/warn/pp_hot +++ /dev/null @@ -1,230 +0,0 @@ - pp_hot.c - - print() on unopened filehandle abc [pp_print] - $f = $a = "abc" ; print $f $a - - Filehandle %s opened only for input [pp_print] - print STDIN "abc" ; - - Filehandle %s opened only for output [pp_print] - print <STDOUT> ; - - print() on closed filehandle %s [pp_print] - close STDIN ; print STDIN "abc" ; - - uninitialized [pp_rv2av] - my $a = undef ; my @b = @$a - - uninitialized [pp_rv2hv] - my $a = undef ; my %b = %$a - - Odd number of elements in hash list [pp_aassign] - %X = (1,2,3) ; - - Reference found where even-sized list expected [pp_aassign] - $X = [ 1 ..3 ]; - - Filehandle %s opened only for output [Perl_do_readline] - open (FH, ">./xcv") ; - my $a = <FH> ; - - glob failed (can't start child: %s) [Perl_do_readline] <<TODO - - readline() on closed filehandle %s [Perl_do_readline] - close STDIN ; $a = <STDIN>; - - readline() on closed filehandle %s [Perl_do_readline] - readline(NONESUCH); - - glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO - - Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] - sub fred { fred() if $a++ < 200} fred() - - Deep recursion on anonymous subroutine [Perl_sub_crush_depth] - $a = sub { &$a if $a++ < 200} &$a - - Possible Y2K bug: about to append an integer to '19' [pp_concat] - $x = "19$yy\n"; - -__END__ -# pp_hot.c [pp_print] -use warnings 'unopened' ; -$f = $a = "abc" ; -print $f $a; -no warnings 'unopened' ; -print $f $a; -EXPECT -print() on unopened filehandle abc at - line 4. -######## -# pp_hot.c [pp_print] -use warnings 'io' ; -print STDIN "anc"; -print <STDOUT>; -print <STDERR>; -open(FOO, ">&STDOUT") and print <FOO>; -print getc(STDERR); -print getc(FOO); -#################################################################### -# The next test is known to fail on some systems (Linux+old glibc, # -# old *BSDs, and NeXT, among others. # -# We skip it for now (on the grounds that it is "just" a warning). # -#################################################################### -#read(FOO,$_,1); -no warnings 'io' ; -print STDIN "anc"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -Filehandle STDOUT opened only for output at - line 4. -Filehandle STDERR opened only for output at - line 5. -Filehandle FOO opened only for output at - line 6. -Filehandle STDERR opened only for output at - line 7. -Filehandle FOO opened only for output at - line 8. -######## -# pp_hot.c [pp_print] -use warnings 'closed' ; -close STDIN ; -print STDIN "anc"; -opendir STDIN, "."; -print STDIN "anc"; -closedir STDIN; -no warnings 'closed' ; -print STDIN "anc"; -opendir STDIN, "."; -print STDIN "anc"; -EXPECT -print() on closed filehandle STDIN at - line 4. -print() on closed filehandle STDIN at - line 6. - (Are you trying to call print() on dirhandle STDIN?) -######## -# pp_hot.c [pp_rv2av] -use warnings 'uninitialized' ; -my $a = undef ; -my @b = @$a; -no warnings 'uninitialized' ; -my @c = @$a; -EXPECT -Use of uninitialized value in array dereference at - line 4. -######## -# pp_hot.c [pp_rv2hv] -use warnings 'uninitialized' ; -my $a = undef ; -my %b = %$a; -no warnings 'uninitialized' ; -my %c = %$a; -EXPECT -Use of uninitialized value in hash dereference at - line 4. -######## -# pp_hot.c [pp_aassign] -use warnings 'misc' ; -my %X ; %X = (1,2,3) ; -no warnings 'misc' ; -my %Y ; %Y = (1,2,3) ; -EXPECT -Odd number of elements in hash assignment at - line 3. -######## -# pp_hot.c [pp_aassign] -use warnings 'misc' ; -my %X ; %X = [1 .. 3] ; -no warnings 'misc' ; -my %Y ; %Y = [1 .. 3] ; -EXPECT -Reference found where even-sized list expected at - line 3. -######## -# pp_hot.c [Perl_do_readline] -use warnings 'closed' ; -close STDIN ; $a = <STDIN> ; -opendir STDIN, "." ; $a = <STDIN> ; -closedir STDIN; -no warnings 'closed' ; -opendir STDIN, "." ; $a = <STDIN> ; -$a = <STDIN> ; -EXPECT -readline() on closed filehandle STDIN at - line 3. -readline() on closed filehandle STDIN at - line 4. - (Are you trying to call readline() on dirhandle STDIN?) -######## -# pp_hot.c [Perl_do_readline] -use warnings 'io' ; -my $file = "./xcv" ; unlink $file ; -open (FH, ">./xcv") ; -my $a = <FH> ; -no warnings 'io' ; -$a = <FH> ; -close (FH) ; -unlink $file ; -EXPECT -Filehandle FH opened only for output at - line 5. -######## -# pp_hot.c [Perl_sub_crush_depth] -use warnings 'recursion' ; -sub fred -{ - fred() if $a++ < 200 -} -{ - local $SIG{__WARN__} = sub { - die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ - }; - fred(); -} -EXPECT -ok -######## -# pp_hot.c [Perl_sub_crush_depth] -no warnings 'recursion' ; -sub fred -{ - fred() if $a++ < 200 -} -{ - local $SIG{__WARN__} = sub { - die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ - }; - fred(); -} -EXPECT - -######## -# pp_hot.c [Perl_sub_crush_depth] -use warnings 'recursion' ; -$b = sub -{ - &$b if $a++ < 200 -} ; - -&$b ; -EXPECT -Deep recursion on anonymous subroutine at - line 5. -######## -# pp_hot.c [Perl_sub_crush_depth] -no warnings 'recursion' ; -$b = sub -{ - &$b if $a++ < 200 -} ; - -&$b ; -EXPECT -######## -# pp_hot.c [pp_concat] -use warnings 'y2k'; -use Config; -BEGIN { - unless ($Config{ccflags} =~ /Y2KWARN/) { - print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; - exit 0; - } -} -my $x; -my $yy = 78; -$x = "19$yy\n"; -$x = "19" . $yy . "\n"; -$x = "319$yy\n"; -$x = "319" . $yy . "\n"; -no warnings 'y2k'; -$x = "19$yy\n"; -$x = "19" . $yy . "\n"; -EXPECT -Possible Y2K bug: about to append an integer to '19' at - line 12. -Possible Y2K bug: about to append an integer to '19' at - line 13. diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys deleted file mode 100644 index 68518e2..0000000 --- a/contrib/perl5/t/pragma/warn/pp_sys +++ /dev/null @@ -1,381 +0,0 @@ - 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] - - printf() on unopened filehandle abc [pp_prtf] - $a = "abc"; printf $a "fred" - - Filehandle %s opened only for input [pp_prtf] - $a = "abc"; - printf $a "fred" - - printf() on closed filehandle %s [pp_prtf] - close STDIN ; - printf STDIN "fred" - - syswrite() on closed filehandle %s [pp_send] - close STDIN; - syswrite STDIN, "fred", 1; - - send() on closed socket %s [pp_send] - close STDIN; - send STDIN, "fred", 1 - - bind() on closed socket %s [pp_bind] - close STDIN; - bind STDIN, "fred" ; - - - connect() on closed socket %s [pp_connect] - close STDIN; - connect STDIN, "fred" ; - - listen() on closed socket %s [pp_listen] - close STDIN; - listen STDIN, 2; - - accept() on closed socket %s [pp_accept] - close STDIN; - accept "fred", STDIN ; - - shutdown() on closed socket %s [pp_shutdown] - close STDIN; - shutdown STDIN, 0; - - setsockopt() on closed socket %s [pp_ssockopt] - getsockopt() on closed socket %s [pp_ssockopt] - close STDIN; - setsockopt STDIN, 1,2,3; - getsockopt STDIN, 1,2; - - getsockname() on closed socket %s [pp_getpeername] - getpeername() on closed socket %s [pp_getpeername] - close STDIN; - getsockname STDIN; - getpeername STDIN; - - flock() on closed socket %s [pp_flock] - flock() on closed socket [pp_flock] - close STDIN; - flock STDIN, 8; - flock $a, 8; - - warn(warn_nl, "stat"); [pp_stat] - - -T on closed filehandle %s - stat() on closed filehandle %s - close STDIN ; -T STDIN ; stat(STDIN) ; - - warn(warn_nl, "open"); [pp_fttext] - -T "abc\ndef" ; - - 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 STDIN opened only for input at - line 5. -######## -# pp_sys.c [pp_leavewrite] -use warnings 'closed' ; -format STDIN = -. -close STDIN; -write STDIN; -opendir STDIN, "."; -write STDIN; -closedir STDIN; -no warnings 'closed' ; -write STDIN; -opendir STDIN, "."; -write STDIN; -EXPECT -write() on closed filehandle STDIN at - line 6. -write() on closed filehandle STDIN at - line 8. - (Are you trying to call write() on dirhandle STDIN?) -######## -# pp_sys.c [pp_leavewrite] -use warnings 'io' ; -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 -printf() on unopened filehandle abc at - line 4. -######## -# pp_sys.c [pp_prtf] -use warnings 'closed' ; -close STDIN ; -printf STDIN "fred"; -opendir STDIN, "."; -printf STDIN "fred"; -closedir STDIN; -no warnings 'closed' ; -printf STDIN "fred"; -opendir STDIN, "."; -printf STDIN "fred"; -EXPECT -printf() on closed filehandle STDIN at - line 4. -printf() on closed filehandle STDIN at - line 6. - (Are you trying to call printf() on dirhandle STDIN?) -######## -# pp_sys.c [pp_prtf] -use warnings 'io' ; -printf STDIN "fred"; -no warnings 'io' ; -printf STDIN "fred"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -######## -# pp_sys.c [pp_send] -use warnings 'closed' ; -close STDIN; -syswrite STDIN, "fred", 1; -opendir STDIN, "."; -syswrite STDIN, "fred", 1; -closedir STDIN; -no warnings 'closed' ; -syswrite STDIN, "fred", 1; -opendir STDIN, "."; -syswrite STDIN, "fred", 1; -EXPECT -syswrite() on closed filehandle STDIN at - line 4. -syswrite() on closed filehandle STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle STDIN?) -######## -# pp_sys.c [pp_flock] -use Config; -BEGIN { - if ( !$Config{d_flock} && - !$Config{d_fcntl_can_lock} && - !$Config{d_lockf} ) { - print <<EOM ; -SKIPPED -# flock not present -EOM - exit ; - } -} -use warnings qw(unopened closed); -close STDIN; -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -no warnings qw(unopened closed); -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -EXPECT -flock() on closed filehandle STDIN at - line 16. -flock() on closed filehandle STDIN at - line 18. - (Are you trying to call flock() on dirhandle STDIN?) -flock() on unopened filehandle FOO at - line 19. -flock() on unopened filehandle at - line 20. -######## -# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] -use warnings 'io' ; -use Config; -BEGIN { - if ( $^O ne 'VMS' and ! $Config{d_socket}) { - print <<EOM ; -SKIPPED -# send not present -# bind not present -# connect not present -# accept not present -# shutdown not present -# setsockopt not present -# getsockopt not present -# getsockname not present -# getpeername not present -EOM - exit ; - } -} -close STDIN; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -opendir STDIN, "."; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -closedir STDIN; -no warnings 'io' ; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept STDIN, "fred" ; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -opendir STDIN, "."; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -EXPECT -send() on closed socket STDIN at - line 22. -bind() on closed socket STDIN at - line 23. -connect() on closed socket STDIN at - line 24. -listen() on closed socket STDIN at - line 25. -accept() on closed socket STDIN at - line 26. -shutdown() on closed socket STDIN at - line 27. -setsockopt() on closed socket STDIN at - line 28. -getsockopt() on closed socket STDIN at - line 29. -getsockname() on closed socket STDIN at - line 30. -getpeername() on closed socket STDIN at - line 31. -send() on closed socket STDIN at - line 33. - (Are you trying to call send() on dirhandle STDIN?) -bind() on closed socket STDIN at - line 34. - (Are you trying to call bind() on dirhandle STDIN?) -connect() on closed socket STDIN at - line 35. - (Are you trying to call connect() on dirhandle STDIN?) -listen() on closed socket STDIN at - line 36. - (Are you trying to call listen() on dirhandle STDIN?) -accept() on closed socket STDIN at - line 37. - (Are you trying to call accept() on dirhandle STDIN?) -shutdown() on closed socket STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle STDIN?) -setsockopt() on closed socket STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle STDIN?) -getsockopt() on closed socket STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle STDIN?) -getsockname() on closed socket STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle STDIN?) -getpeername() on closed socket STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle STDIN?) -######## -# pp_sys.c [pp_stat] -use warnings 'newline' ; -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 qw(unopened closed) ; -close STDIN ; --T STDIN ; -stat(STDIN) ; --T HOCUS; -stat(POCUS); -no warnings qw(unopened closed) ; --T STDIN ; -stat(STDIN); --T HOCUS; -stat(POCUS); -EXPECT --T on closed filehandle STDIN at - line 4. -stat() on closed filehandle STDIN at - line 5. --T on unopened filehandle HOCUS at - line 6. -stat() on unopened filehandle POCUS at - line 7. -######## -# pp_sys.c [pp_fttext] -use warnings 'newline' ; --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' ; -if ($^O eq 'dos') { - print <<EOM ; -SKIPPED -# skipped on dos -EOM - exit ; -} -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 F opened only for output at - line 12. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp deleted file mode 100644 index 8b86b50..0000000 --- a/contrib/perl5/t/pragma/warn/regcomp +++ /dev/null @@ -1,167 +0,0 @@ - regcomp.c AOK - - Strange *+?{} on zero-length expression [S_study_chunk] - /(?=a)?/ - - %.*s matches null string many times [S_regpiece] - $a = "ABC123" ; $a =~ /(?=a)*/' - - /%.127s/: Unrecognized escape \\%c passed through [S_regatom] - $x = '\m' ; /$x/ - - Character class [:%.*s:] unknown [S_regpposixcc] - - Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] - - /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] - - /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8] - - /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass] - - /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8] - -__END__ -# regcomp.c [S_regpiece] -use warnings 'regexp' ; -my $a = "ABC123" ; -$a =~ /(?=a)*/ ; -no warnings 'regexp' ; -$a =~ /(?=a)*/ ; -EXPECT -(?=a)* matches null string many times before HERE mark in regex m/(?=a)* << HERE / at - line 4. -######## -# regcomp.c [S_study_chunk] -use warnings 'regexp' ; -$_ = "" ; -/(?=a)?/; -no warnings 'regexp' ; -/(?=a)?/; -EXPECT -Quantifier unexpected on zero-length expression before HERE mark in regex m/(?=a)? << HERE / at - line 4. -######## -# regcomp.c [S_regatom] -$x = '\m' ; -use warnings 'regexp' ; -$a =~ /a$x/ ; -no warnings 'regexp' ; -$a =~ /a$x/ ; -EXPECT -Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4. -######## -# regcomp.c [S_regpposixcc S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -no warnings 'regexp' ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -EXPECT -POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:alpha:] << HERE / at - line 5. -POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:zog:] << HERE / at - line 6. -POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/ -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[.zog.]/; -no warnings 'regexp' ; -/[.zog.]/; -EXPECT -POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/[.zog.] << HERE / at - line 5. -POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE / -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[[.zog.]]/; -no warnings 'regexp' ; -/[[.zog.]]/; -EXPECT -POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[[.zog.] << HERE ]/ -######## -# regcomp.c [S_regclass] -$_ = ""; -use warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -no warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -EXPECT -False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 5. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 6. -False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 7. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 8. -False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 9. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 10. -False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 11. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 12. -######## -# regcomp.c [S_regclassutf8] -BEGIN { - if (ord("\t") == 5) { - print "SKIPPED\n# ebcdic regular expression ranges differ."; - exit 0; - } -} -use utf8; -$_ = ""; -use warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -no warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -EXPECT -False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 12. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 13. -False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 14. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 15. -False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 16. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 17. -False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 18. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 19. -######## -# regcomp.c [S_regclass S_regclassutf8] -use warnings 'regexp' ; -$a =~ /[a\zb]/ ; -no warnings 'regexp' ; -$a =~ /[a\zb]/ ; -EXPECT -Unrecognized escape \z in character class passed through before HERE mark in regex m/[a\z << HERE b]/ at - line 3. - diff --git a/contrib/perl5/t/pragma/warn/regexec b/contrib/perl5/t/pragma/warn/regexec deleted file mode 100644 index 73696df..0000000 --- a/contrib/perl5/t/pragma/warn/regexec +++ /dev/null @@ -1,119 +0,0 @@ - regexec.c - - This test generates "bad free" warnings when run under - PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder - for investigation. - - Complex regular subexpression recursion limit (%d) exceeded - - $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; - Complex regular subexpression recursion limit (%d) exceeded - - $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; - - (The actual value substituted for %d is masked in the tests so that - REG_INFTY configuration variable value does not affect outcome.) -__END__ -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -use warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT -Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -no warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT - -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -use warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*?$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT -Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -no warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*?$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/run b/contrib/perl5/t/pragma/warn/run deleted file mode 100644 index 7a4be20..0000000 --- a/contrib/perl5/t/pragma/warn/run +++ /dev/null @@ -1,8 +0,0 @@ - run.c - - - Mandatory Warnings ALL TODO - ------------------ - NULL OP IN RUN - -__END__ diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv deleted file mode 100644 index 2409589..0000000 --- a/contrib/perl5/t/pragma/warn/sv +++ /dev/null @@ -1,303 +0,0 @@ - sv.c - - warn(warn_uninit); - - warn(warn_uninit); - - warn(warn_uninit); - - warn(warn_uninit); - - not_a_number(sv); - - not_a_number(sv); - - warn(warn_uninit); - - not_a_number(sv); - - warn(warn_uninit); - - not_a_number(sv); - - not_a_number(sv); - - warn(warn_uninit); - - warn(warn_uninit); - - Subroutine %s redefined - - Invalid conversion in %s: - - Undefined value assigned to typeglob - - Possible Y2K bug: %d format string following '19' - - Reference is already weak [Perl_sv_rvweaken] <<TODO - - Mandatory Warnings - ------------------ - Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce - with perl now) - - Mandatory Warnings TODO - ------------------ - Attempt to free non-arena SV: 0x%lx [del_sv] - Reference miscount in sv_replace() [sv_replace] - Attempt to free unreferenced scalar [sv_free] - Attempt to free temp prematurely: SV 0x%lx [sv_free] - semi-panic: attempt to dup freed string [newSVsv] - - -__END__ -# sv.c -use integer ; -use warnings 'uninitialized' ; -$x = 1 + $a[0] ; # a -no warnings 'uninitialized' ; -$x = 1 + $b[0] ; # a -EXPECT -Use of uninitialized value in integer addition (+) at - line 4. -######## -# sv.c (sv_2iv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use integer ; -use warnings 'uninitialized' ; -$A *= 2 ; -no warnings 'uninitialized' ; -$A *= 2 ; -EXPECT -Use of uninitialized value in integer multiplication (*) at - line 10. -######## -# sv.c -use integer ; -use warnings 'uninitialized' ; -my $x *= 2 ; #b -no warnings 'uninitialized' ; -my $y *= 2 ; #b -EXPECT -Use of uninitialized value in integer multiplication (*) at - line 4. -######## -# sv.c (sv_2uv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$B = 0 ; -$B |= $A ; -no warnings 'uninitialized' ; -$B = 0 ; -$B |= $A ; -EXPECT -Use of uninitialized value in bitwise or (|) at - line 10. -######## -# sv.c -use warnings 'uninitialized' ; -my $Y = 1 ; -my $x = 1 | $a[$Y] ; -no warnings 'uninitialized' ; -my $Y = 1 ; -$x = 1 | $b[$Y] ; -EXPECT -Use of uninitialized value in bitwise or (|) at - line 4. -######## -# sv.c -use warnings 'uninitialized' ; -my $x *= 1 ; # d -no warnings 'uninitialized' ; -my $y *= 1 ; # d -EXPECT -Use of uninitialized value in multiplication (*) at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = 1 + $a[0] ; # e -no warnings 'uninitialized' ; -$x = 1 + $b[0] ; # e -EXPECT -Use of uninitialized value in addition (+) at - line 3. -######## -# sv.c (sv_2nv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$A *= 2 ; -no warnings 'uninitialized' ; -$A *= 2 ; -EXPECT -Use of uninitialized value in multiplication (*) at - line 9. -######## -# sv.c -use warnings 'uninitialized' ; -$x = $y + 1 ; # f -no warnings 'uninitialized' ; -$x = $z + 1 ; # f -EXPECT -Use of uninitialized value in addition (+) at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = chop undef ; # g -no warnings 'uninitialized' ; -$x = chop undef ; # g -EXPECT -Modification of a read-only value attempted at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = chop $y ; # h -no warnings 'uninitialized' ; -$x = chop $z ; # h -EXPECT -Use of uninitialized value in scalar chop at - line 3. -######## -# sv.c (sv_2pv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$B = "" ; -$B .= $A ; -no warnings 'uninitialized' ; -$C = "" ; -$C .= $A ; -EXPECT -Use of uninitialized value in concatenation (.) or string at - line 10. -######## -# sv.c -use warnings 'numeric' ; -sub TIESCALAR{bless[]} ; -sub FETCH {"def"} ; -tie $a,"main" ; -my $b = 1 + $a; -no warnings 'numeric' ; -my $c = 1 + $a; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 6. -######## -# sv.c -use warnings 'numeric' ; -my $x = 1 + "def" ; -no warnings 'numeric' ; -my $z = 1 + "def" ; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 3. -######## -# sv.c -use warnings 'numeric' ; -my $a = "def" ; -my $x = 1 + $a ; -no warnings 'numeric' ; -my $y = 1 + $a ; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 4. -######## -# sv.c -use warnings 'numeric' ; use integer ; -my $a = "def" ; -my $x = 1 + $a ; -no warnings 'numeric' ; -my $z = 1 + $a ; -EXPECT -Argument "def" isn't numeric in integer addition (+) at - line 4. -######## -# sv.c -use warnings 'numeric' ; -my $x = 1 & "def" ; -no warnings 'numeric' ; -my $z = 1 & "def" ; -EXPECT -Argument "def" isn't numeric in bitwise and (&) at - line 3. -######## -# sv.c -use warnings 'redefine' ; -sub fred {} -sub joe {} -*fred = \&joe ; -no warnings 'redefine' ; -sub jim {} -*jim = \&joe ; -EXPECT -Subroutine fred redefined at - line 5. -######## -# sv.c -use warnings 'printf' ; -open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; -printf F "%z\n" ; -my $a = sprintf "%z" ; -printf F "%" ; -$a = sprintf "%" ; -printf F "%\x02" ; -$a = sprintf "%\x02" ; -no warnings 'printf' ; -printf F "%z\n" ; -$a = sprintf "%z" ; -printf F "%" ; -$a = sprintf "%" ; -printf F "%\x02" ; -$a = sprintf "%\x02" ; -EXPECT -Invalid conversion in sprintf: "%z" at - line 5. -Invalid conversion in sprintf: end of string at - line 7. -Invalid conversion in sprintf: "%\002" at - line 9. -Invalid conversion in printf: "%z" at - line 4. -Invalid conversion in printf: end of string at - line 6. -Invalid conversion in printf: "%\002" at - line 8. -######## -# sv.c -use warnings 'misc' ; -*a = undef ; -no warnings 'misc' ; -*b = undef ; -EXPECT -Undefined value assigned to typeglob at - line 3. -######## -# sv.c -use warnings 'y2k'; -use Config; -BEGIN { - unless ($Config{ccflags} =~ /Y2KWARN/) { - print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; - exit 0; - } - $|=1; -} -my $x; -my $yy = 78; -$x = printf "19%02d\n", $yy; -$x = sprintf "#19%02d\n", $yy; -$x = printf " 19%02d\n", 78; -$x = sprintf "19%02d\n", 78; -$x = printf "319%02d\n", $yy; -$x = sprintf "319%02d\n", $yy; -no warnings 'y2k'; -$x = printf "19%02d\n", $yy; -$x = sprintf "19%02d\n", $yy; -$x = printf "19%02d\n", 78; -$x = sprintf "19%02d\n", 78; -EXPECT -Possible Y2K bug: %d format string following '19' at - line 16. -Possible Y2K bug: %d format string following '19' at - line 13. -1978 -Possible Y2K bug: %d format string following '19' at - line 14. -Possible Y2K bug: %d format string following '19' at - line 15. - 1978 -31978 -1978 -1978 diff --git a/contrib/perl5/t/pragma/warn/taint b/contrib/perl5/t/pragma/warn/taint deleted file mode 100644 index fd6deed..0000000 --- a/contrib/perl5/t/pragma/warn/taint +++ /dev/null @@ -1,49 +0,0 @@ - taint.c AOK - - Insecure %s%s while running with -T switch - -__END__ --T ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -chdir $a ; -print "xxx\n" ; -EXPECT -Insecure dependency in chdir while running with -T switch at - line 5. -######## --TU ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -chdir $a ; -print "xxx\n" ; -EXPECT -xxx -######## --TU ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -use warnings 'taint' ; -chdir $a ; -print "xxx\n" ; -no warnings 'taint' ; -chdir $a ; -print "yyy\n" ; -EXPECT -Insecure dependency in chdir while running with -T switch at - line 6. -xxx -yyy diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke deleted file mode 100644 index fa71329..0000000 --- a/contrib/perl5/t/pragma/warn/toke +++ /dev/null @@ -1,587 +0,0 @@ -toke.c AOK - - we seem to have lost a few ambiguous warnings!! - - - 1 if $a EQ $b ; - 1 if $a NE $b ; - 1 if $a LT $b ; - 1 if $a GT $b ; - 1 if $a GE $b ; - 1 if $a LE $b ; - $a = <<; - Use of comma-less variable list is deprecated - (called 3 times via depcom) - - \1 better written as $1 - use warnings 'syntax' ; - s/(abc)/\1/; - - warn(warn_nosemi) - Semicolon seems to be missing - $a = 1 - &time ; - - - Reversed %c= operator - my $a =+ 2 ; - $a =- 2 ; - $a =* 2 ; - $a =% 2 ; - $a =& 2 ; - $a =. 2 ; - $a =^ 2 ; - $a =| 2 ; - $a =< 2 ; - $a =/ 2 ; - - Multidimensional syntax %.*s not supported - my $a = $a[1,2] ; - - You need to quote \"%s\"" - sub fred {} ; $SIG{TERM} = fred; - - Scalar value %.*s better written as $%.*s" - @a[3] = 2; - @a{3} = 2; - - Can't use \\%c to mean $%c in expression - $_ = "ab" ; s/(ab)/\1/e; - - Unquoted string "abc" may clash with future reserved word at - line 3. - warn(warn_reserved - $a = abc; - - chmod() mode argument is missing initial 0 - chmod 3; - - Possible attempt to separate words with commas - @a = qw(a, b, c) ; - - Possible attempt to put comments in qw() list - @a = qw(a b # c) ; - - umask: argument is missing initial 0 - umask 3; - - %s (...) interpreted as function - print ("") - printf ("") - sort ("") - - Ambiguous use of %c{%s%s} resolved to %c%s%s - $a = ${time[2]} - $a = ${time{2}} - - - Ambiguous use of %c{%s} resolved to %c%s - $a = ${time} - sub fred {} $a = ${fred} - - Misplaced _ in number - $a = 1_2; - $a = 1_2345_6; - - Bareword \"%s\" refers to nonexistent package - $a = FRED:: ; - - Ambiguous call resolved as CORE::%s(), qualify as such or use & - sub time {} - my $a = time() - - Unrecognized escape \\%c passed through - $a = "\m" ; - - %s number > %s non-portable - my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; - - Integer overflow in binary number - my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; - - Mandatory Warnings - ------------------ - Use of "%s" without parentheses is ambiguous [check_uni] - rand + 4 - - Ambiguous use of -%s resolved as -&%s() [yylex] - sub fred {} ; - fred ; - - Precedence problem: open %.*s should be open(%.*s) [yylex] - open FOO || die; - - Operator or semicolon missing before %c%s [yylex] - Ambiguous use of %c resolved as operator %c - *foo *foo - -__END__ -# toke.c -use warnings 'deprecated' ; -1 if $a EQ $b ; -1 if $a NE $b ; -1 if $a GT $b ; -1 if $a LT $b ; -1 if $a GE $b ; -1 if $a LE $b ; -no warnings 'deprecated' ; -1 if $a EQ $b ; -1 if $a NE $b ; -1 if $a GT $b ; -1 if $a LT $b ; -1 if $a GE $b ; -1 if $a LE $b ; -EXPECT -Use of EQ is deprecated at - line 3. -Use of NE is deprecated at - line 4. -Use of GT is deprecated at - line 5. -Use of LT is deprecated at - line 6. -Use of GE is deprecated at - line 7. -Use of LE is deprecated at - line 8. -######## -# toke.c -use warnings 'deprecated' ; -format STDOUT = -@<<< @||| @>>> @>>> -$a $b "abc" 'def' -. -no warnings 'deprecated' ; -format STDOUT = -@<<< @||| @>>> @>>> -$a $b "abc" 'def' -. -EXPECT -Use of comma-less variable list is deprecated at - line 5. -Use of comma-less variable list is deprecated at - line 5. -Use of comma-less variable list is deprecated at - line 5. -######## -# toke.c -use warnings 'deprecated' ; -$a = <<; - -no warnings 'deprecated' ; -$a = <<; - -EXPECT -Use of bare << to mean <<"" is deprecated at - line 3. -######## -# toke.c -use warnings 'syntax' ; -s/(abc)/\1/; -no warnings 'syntax' ; -s/(abc)/\1/; -EXPECT -\1 better written as $1 at - line 3. -######## -# toke.c -use warnings 'semicolon' ; -$a = 1 -&time ; -no warnings 'semicolon' ; -$a = 1 -&time ; -EXPECT -Semicolon seems to be missing at - line 3. -######## -# toke.c -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 3. -Reversed -= operator at - line 4. -Reversed *= operator at - line 5. -Reversed %= operator at - line 6. -Reversed &= operator at - line 7. -Reversed .= operator at - line 8. -Reversed ^= operator at - line 9. -Reversed |= operator at - line 10. -Reversed <= operator at - line 11. -syntax error at - line 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# toke.c -no warnings 'syntax' ; -my $a =+ 2 ; -$a =- 2 ; -$a =* 2 ; -$a =% 2 ; -$a =& 2 ; -$a =. 2 ; -$a =^ 2 ; -$a =| 2 ; -$a =< 2 ; -$a =/ 2 ; -EXPECT -syntax error at - line 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# toke.c -use warnings 'syntax' ; -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; -$a = { def - -=> 1 }; -no warnings 'reserved' ; -$a = abc; -EXPECT -Unquoted string "abc" may clash with future reserved word at - line 3. -######## -# toke.c -use warnings 'chmod' ; -chmod 3; -no warnings 'chmod' ; -chmod 3; -EXPECT -chmod() mode argument is missing initial 0 at - line 3. -######## -# toke.c -use warnings 'qw' ; -@a = qw(a, b, c) ; -no warnings 'qw' ; -@a = qw(a, b, c) ; -EXPECT -Possible attempt to separate words with commas at - line 3. -######## -# toke.c -use warnings 'qw' ; -@a = qw(a b #) ; -no warnings 'qw' ; -@a = qw(a b #) ; -EXPECT -Possible attempt to put comments in qw() list at - line 3. -######## -# toke.c -use warnings 'umask' ; -umask 3; -no warnings 'umask' ; -umask 3; -EXPECT -umask: argument is missing initial 0 at - line 3. -######## -# toke.c -use warnings 'syntax' ; -print ("") -EXPECT -print (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -print ("") -EXPECT - -######## -# toke.c -use warnings 'syntax' ; -printf ("") -EXPECT -printf (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -printf ("") -EXPECT - -######## -# toke.c -use warnings 'syntax' ; -sort ("") -EXPECT -sort (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -sort ("") -EXPECT - -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time[2]}; -no warnings 'ambiguous' ; -$a = ${time[2]}; -EXPECT -Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time{2}}; -EXPECT -Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. -######## -# toke.c -no warnings 'ambiguous' ; -$a = ${time{2}}; -EXPECT - -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time} ; -no warnings 'ambiguous' ; -$a = ${time} ; -EXPECT -Ambiguous use of ${time} resolved to $time at - line 3. -######## -# toke.c -use warnings 'ambiguous' ; -sub fred {} -$a = ${fred} ; -no warnings 'ambiguous' ; -$a = ${fred} ; -EXPECT -Ambiguous use of ${fred} resolved to $fred at - line 4. -######## -# toke.c -use warnings 'syntax' ; -$a = 1_2; -$a = 1_2345_6; -no warnings 'syntax' ; -$a = 1_2; -$a = 1_2345_6; -EXPECT -Misplaced _ in number at - line 3. -Misplaced _ in number at - line 4. -Misplaced _ in number at - line 4. -######## -# toke.c -use warnings 'bareword' ; -#line 25 "bar" -$a = FRED:: ; -no warnings 'bareword' ; -#line 25 "bar" -$a = FRED:: ; -EXPECT -Bareword "FRED::" refers to nonexistent package at bar line 25. -######## -# toke.c -use warnings 'ambiguous' ; -sub time {} -my $a = time() ; -no warnings 'ambiguous' ; -my $b = time() ; -EXPECT -Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. -######## -# toke.c -use warnings ; -eval <<'EOE'; -# line 30 "foo" -warn "yelp"; -{ - $_ = " \x{123} " ; -} -EOE -EXPECT -yelp at foo line 30. -######## -# toke.c -my $a = rand + 4 ; -EXPECT -Warning: Use of "rand" without parens is ambiguous at - line 2. -######## -# toke.c -$^W = 0 ; -my $a = rand + 4 ; -{ - no warnings 'ambiguous' ; - $a = rand + 4 ; - use warnings 'ambiguous' ; - $a = rand + 4 ; -} -$a = rand + 4 ; -EXPECT -Warning: Use of "rand" without parens is ambiguous at - line 3. -Warning: Use of "rand" without parens is ambiguous at - line 8. -Warning: Use of "rand" without parens is ambiguous at - line 10. -######## -# toke.c -sub fred {}; --fred ; -EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 3. -######## -# toke.c -$^W = 0 ; -sub fred {} ; --fred ; -{ - no warnings 'ambiguous' ; - -fred ; - use warnings 'ambiguous' ; - -fred ; -} --fred ; -EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 4. -Ambiguous use of -fred resolved as -&fred() at - line 9. -Ambiguous use of -fred resolved as -&fred() at - line 11. -######## -# toke.c -open FOO || time; -EXPECT -Precedence problem: open FOO should be open(FOO) at - line 2. -######## -# toke.c -$^W = 0 ; -open FOO || time; -{ - no warnings 'precedence' ; - open FOO || time; - use warnings 'precedence' ; - open FOO || time; -} -open FOO || time; -EXPECT -Precedence problem: open FOO should be open(FOO) at - line 3. -Precedence problem: open FOO should be open(FOO) at - line 8. -Precedence problem: open FOO should be open(FOO) at - line 10. -######## -# toke.c -$^W = 0 ; -*foo *foo ; -{ - no warnings 'ambiguous' ; - *foo *foo ; - use warnings 'ambiguous' ; - *foo *foo ; -} -*foo *foo ; -EXPECT -Operator or semicolon missing before *foo at - line 3. -Ambiguous use of * resolved as operator * at - line 3. -Operator or semicolon missing before *foo at - line 8. -Ambiguous use of * resolved as operator * at - line 8. -Operator or semicolon missing before *foo at - line 10. -Ambiguous use of * resolved as operator * at - line 10. -######## -# toke.c -use warnings 'misc' ; -my $a = "\m" ; -no warnings 'misc' ; -$a = "\m" ; -EXPECT -Unrecognized escape \m passed through at - line 3. -######## -# toke.c -use warnings 'portable' ; -my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; -no warnings 'portable' ; - $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; -EXPECT -Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. -Hexadecimal number > 0xffffffff non-portable at - line 8. -Octal number > 037777777777 non-portable at - line 11. -######## -# toke.c -use warnings 'overflow' ; -my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x10000000000000000 ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 002000000000000000000000; -no warnings 'overflow' ; - $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x10000000000000000 ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 002000000000000000000000; -EXPECT -Integer overflow in binary number at - line 5. -Integer overflow in hexadecimal number at - line 8. -Integer overflow in octal number at - line 11. -######## -# toke.c -use warnings 'ambiguous'; -"@mjd_previously_unused_array"; -no warnings 'ambiguous'; -"@mjd_previously_unused_array"; -EXPECT -Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/contrib/perl5/t/pragma/warn/universal b/contrib/perl5/t/pragma/warn/universal deleted file mode 100644 index 6dbb1be..0000000 --- a/contrib/perl5/t/pragma/warn/universal +++ /dev/null @@ -1,16 +0,0 @@ - universal.c AOK - - Can't locate package %s for @%s::ISA [S_isa_lookup] - - - -__END__ -# universal.c [S_isa_lookup] -use warnings 'misc' ; -@ISA = qw(Joe) ; -my $a = bless [] ; -UNIVERSAL::isa $a, Jim ; -EXPECT -Can't locate package Joe for @main::ISA at - line 5. -Can't locate package Joe for @main::ISA. -Can't locate package Joe for @main::ISA. diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8 deleted file mode 100644 index 9a7dbaf..0000000 --- a/contrib/perl5/t/pragma/warn/utf8 +++ /dev/null @@ -1,35 +0,0 @@ - - utf8.c AOK - - [utf8_to_uv] - Malformed UTF-8 character - my $a = ord "\x80" ; - - Malformed UTF-8 character - my $a = ord "\xf080" ; - <<<<<< this warning can't be easily triggered from perl anymore - - [utf16_to_utf8] - Malformed UTF-16 surrogate - <<<<<< Add a test when somethig actually calls utf16_to_utf8 - -__END__ -# utf8.c [utf8_to_uv] -W -BEGIN { - if (ord('A') == 193) { - print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; - exit 0; - } -} -use utf8 ; -my $a = "snstorm" ; -{ - no warnings 'utf8' ; - my $a = "snstorm"; - use warnings 'utf8' ; - my $a = "snstorm"; -} -EXPECT -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9. -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14. -######## diff --git a/contrib/perl5/t/pragma/warn/util b/contrib/perl5/t/pragma/warn/util deleted file mode 100644 index e82d6a6..0000000 --- a/contrib/perl5/t/pragma/warn/util +++ /dev/null @@ -1,108 +0,0 @@ - util.c AOK - - Illegal octal digit ignored - my $a = oct "029" ; - - Illegal hex digit ignored - my $a = hex "0xv9" ; - - Illegal binary digit ignored - my $a = oct "0b9" ; - - Integer overflow in binary number - my $a = oct "0b111111111111111111111111111111111111111111" ; - Binary number > 0b11111111111111111111111111111111 non-portable - $a = oct "0b111111111111111111111111111111111" ; - Integer overflow in octal number - my $a = oct "077777777777777777777777777777" ; - Octal number > 037777777777 non-portable - $a = oct "0047777777777" ; - Integer overflow in hexadecimal number - my $a = hex "0xffffffffffffffffffff" ; - Hexadecimal number > 0xffffffff non-portable - $a = hex "0x1ffffffff" ; - -__END__ -# util.c -use warnings 'digit' ; -my $a = oct "029" ; -no warnings 'digit' ; -$a = oct "029" ; -EXPECT -Illegal octal digit '9' ignored at - line 3. -######## -# util.c -use warnings 'digit' ; -my $a = hex "0xv9" ; -no warnings 'digit' ; -$a = hex "0xv9" ; -EXPECT -Illegal hexadecimal digit 'v' ignored at - line 3. -######## -# util.c -use warnings 'digit' ; -my $a = oct "0b9" ; -no warnings 'digit' ; -$a = oct "0b9" ; -EXPECT -Illegal binary digit '9' ignored at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; -no warnings 'overflow' ; -$a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; -EXPECT -Integer overflow in binary number at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = hex "0xffffffffffffffffffff" ; -no warnings 'overflow' ; -$a = hex "0xffffffffffffffffffff" ; -EXPECT -Integer overflow in hexadecimal number at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = oct "077777777777777777777777777777" ; -no warnings 'overflow' ; -$a = oct "077777777777777777777777777777" ; -EXPECT -Integer overflow in octal number at - line 3. -######## -# util.c -use warnings 'portable' ; -my $a = oct "0b011111111111111111111111111111110" ; - $a = oct "0b011111111111111111111111111111111" ; - $a = oct "0b111111111111111111111111111111111" ; -no warnings 'portable' ; - $a = oct "0b011111111111111111111111111111110" ; - $a = oct "0b011111111111111111111111111111111" ; - $a = oct "0b111111111111111111111111111111111" ; -EXPECT -Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. -######## -# util.c -use warnings 'portable' ; -my $a = hex "0x0fffffffe" ; - $a = hex "0x0ffffffff" ; - $a = hex "0x1ffffffff" ; -no warnings 'portable' ; - $a = hex "0x0fffffffe" ; - $a = hex "0x0ffffffff" ; - $a = hex "0x1ffffffff" ; -EXPECT -Hexadecimal number > 0xffffffff non-portable at - line 5. -######## -# util.c -use warnings 'portable' ; -my $a = oct "0037777777776" ; - $a = oct "0037777777777" ; - $a = oct "0047777777777" ; -no warnings 'portable' ; - $a = oct "0037777777776" ; - $a = oct "0037777777777" ; - $a = oct "0047777777777" ; -EXPECT -Octal number > 037777777777 non-portable at - line 5. diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t deleted file mode 100755 index 66b4ff9..0000000 --- a/contrib/perl5/t/pragma/warnings.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; - require Config; import Config; -} - -$| = 1; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile} } - -my @prgs = () ; -my @w_files = () ; - -if (@ARGV) - { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV } -else - { @w_files = sort glob("pragma/warn/*") } - -foreach (@w_files) { - - next if /(~|\.orig|,v)$/; - - open F, "<$_" or die "Cannot open $_: $!\n" ; - while (<F>) { - last if /^__END__/ ; - } - - { - local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; - } - close F ; -} - -undef $/; - -print "1..", scalar @prgs, "\n"; - - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_VMS ? - `./perl "-I../lib" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - `./perl -I../lib $switch $tmpfile 2>&1`; - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/tmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg -# bison says 'parse error' instead of 'syntax error', -# various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - $expected =~ s/\n+$//; - my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - if ($expected =~ s/^OPTIONS? (.+)\n//) { - foreach my $option (split(' ', $1)) { - if ($option eq 'regex') { # allow regular expressions - $option_regex = 1; - } else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || - (!$option_regex && $results !~ /^\Q$expected/))) or - (!$prefix && (( $option_regex && $results !~ /^$expected/) || - (!$option_regex && $results ne $expected)))) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} diff --git a/contrib/perl5/t/run/runenv.t b/contrib/perl5/t/run/runenv.t deleted file mode 100755 index a59ad26..0000000 --- a/contrib/perl5/t/run/runenv.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./perl -# -# Tests for Perl run-time environment variable settings -# -# $PERL5OPT, $PERL5LIB, etc. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - unless ($Config{'d_fork'}) { - print "1..0 # Skip: no fork\n"; - exit 0; - } -} - -my $STDOUT = './results-0'; -my $STDERR = './results-1'; -my $PERL = './perl'; -my $FAILURE_CODE = 119; - -print "1..9\n"; - -# Run perl with specified environment and arguments returns a list. -# First element is true iff Perl's stdout and stderr match the -# supplied $stdout and $stderr argument strings exactly. -# second element is an explanation of the failure -sub runperl { - local *F; - my ($env, $args, $stdout, $stderr) = @_; - - unshift @$args, '-I../lib'; - - $stdout = '' unless defined $stdout; - $stderr = '' unless defined $stderr; - my $pid = fork; - return (0, "Couldn't fork: $!") unless defined $pid; # failure - if ($pid) { # parent - my ($actual_stdout, $actual_stderr); - wait; - return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE; - - open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file"); - { local $/; $actual_stdout = <F> } - open F, "< $STDERR" or return (0, "Couldn't read $STDERR file"); - { local $/; $actual_stderr = <F> } - - if ($actual_stdout ne $stdout) { - return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]"); - } elsif ($actual_stderr ne $stderr) { - return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]"); - } else { - return 1; # success - } - } else { # child - for my $k (keys %$env) { - $ENV{$k} = $env->{$k}; - } - open STDOUT, "> $STDOUT" or exit $FAILURE_CODE; - open STDERR, "> $STDERR" or it_didnt_work(); - { exec $PERL, @$args } - it_didnt_work(); - } -} - - -sub it_didnt_work { - print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; - exit $FAILURE_CODE; -} - -sub try { - my $testno = shift; - my ($success, $reason) = runperl(@_); - if ($success) { - print "ok $testno\n"; - } else { - $reason =~ s/\n/\\n/g; - print "not ok $testno # $reason\n"; - } -} - -# PERL5OPT Command-line options (switches). Switches in -# this variable are taken as if they were on -# every Perl command line. Only the -[DIMUdmw] -# switches are allowed. When running taint -# checks (because the program was running setuid -# or setgid, or the -T switch was used), this -# variable is ignored. If PERL5OPT begins with -# -T, tainting will be enabled, and any -# subsequent options ignored. - -my $T = 1; -try($T++, {PERL5OPT => '-w'}, ['-e', 'print $::x'], - "", - qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n}); - -try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'], - "", ""); - -try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $x'], - "", - qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); - -# Fails in 5.6.0 -try($T++, {PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'], - "", - qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); - -# Fails in 5.6.0 -try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'], - "", - <<ERROR -Name "main::x" used only once: possible typo at -e line 1. -Use of uninitialized value in print at -e line 1. -ERROR - ); - -# Fails in 5.6.0 -try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'], - "", - <<ERROR -Name "main::x" used only once: possible typo at -e line 1. -Use of uninitialized value in print at -e line 1. -ERROR - ); - -try($T++, {PERL5OPT => '-MExporter'}, ['-e0'], - "", - ""); - -# Fails in 5.6.0 -try($T++, {PERL5OPT => '-MExporter -MExporter'}, ['-e0'], - "", - ""); - -try($T++, {PERL5OPT => '-Mstrict -Mwarnings'}, - ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'], - "ok", - ""); - -print "# ", $T-1, " tests total.\n"; - -END { - 1 while unlink $STDOUT; - 1 while unlink $STDERR; -} |
