diff options
Diffstat (limited to 'contrib/perl5/t')
197 files changed, 23110 insertions, 0 deletions
diff --git a/contrib/perl5/t/README b/contrib/perl5/t/README new file mode 100644 index 0000000..8384349 --- /dev/null +++ b/contrib/perl5/t/README @@ -0,0 +1,16 @@ +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 larry@wall.org. diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST new file mode 100755 index 0000000..3685c2a --- /dev/null +++ b/contrib/perl5/t/TEST @@ -0,0 +1,181 @@ +#!./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'; + +# 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 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 + + $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 ./$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 new file mode 100755 index 0000000..9a57348 --- /dev/null +++ b/contrib/perl5/t/base/cond.t @@ -0,0 +1,19 @@ +#!./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 new file mode 100755 index 0000000..12db765 --- /dev/null +++ b/contrib/perl5/t/base/if.t @@ -0,0 +1,11 @@ +#!./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 new file mode 100755 index 0000000..045cb22 --- /dev/null +++ b/contrib/perl5/t/base/lex.t @@ -0,0 +1,119 @@ +#!./perl + +# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ + +print "1..30\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; diff --git a/contrib/perl5/t/base/pat.t b/contrib/perl5/t/base/pat.t new file mode 100755 index 0000000..c689f45 --- /dev/null +++ b/contrib/perl5/t/base/pat.t @@ -0,0 +1,11 @@ +#!./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 new file mode 100755 index 0000000..52a9572 --- /dev/null +++ b/contrib/perl5/t/base/rs.t @@ -0,0 +1,131 @@ +#!./perl +# Test $! + +print "1..14\n"; + +$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; + +# Create our test datafile +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; + unlink "./foo.bar"; + unlink "./foo.com"; +} 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 new file mode 100755 index 0000000..e96313d --- /dev/null +++ b/contrib/perl5/t/base/term.t @@ -0,0 +1,55 @@ +#!./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, "../Configure") || (die "Can't open ../Configure."); +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 new file mode 100755 index 0000000..7eace16 --- /dev/null +++ b/contrib/perl5/t/cmd/elsif.t @@ -0,0 +1,25 @@ +#!./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 new file mode 100755 index 0000000..e45f050 --- /dev/null +++ b/contrib/perl5/t/cmd/for.t @@ -0,0 +1,49 @@ +#!./perl + +# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $ + +print "1..7\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; +} diff --git a/contrib/perl5/t/cmd/mod.t b/contrib/perl5/t/cmd/mod.t new file mode 100755 index 0000000..e2ab777 --- /dev/null +++ b/contrib/perl5/t/cmd/mod.t @@ -0,0 +1,54 @@ +#!./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 new file mode 100755 index 0000000..3c60690 --- /dev/null +++ b/contrib/perl5/t/cmd/subval.t @@ -0,0 +1,186 @@ +#!./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 new file mode 100755 index 0000000..faa5de4 --- /dev/null +++ b/contrib/perl5/t/cmd/switch.t @@ -0,0 +1,75 @@ +#!./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 new file mode 100755 index 0000000..c6e464d --- /dev/null +++ b/contrib/perl5/t/cmd/while.t @@ -0,0 +1,111 @@ +#!./perl + +# $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $ + +print "1..10\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"; diff --git a/contrib/perl5/t/comp/cmdopt.t b/contrib/perl5/t/comp/cmdopt.t new file mode 100755 index 0000000..3f701a4 --- /dev/null +++ b/contrib/perl5/t/comp/cmdopt.t @@ -0,0 +1,90 @@ +#!./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 new file mode 100755 index 0000000..d2c64fe --- /dev/null +++ b/contrib/perl5/t/comp/colon.t @@ -0,0 +1,138 @@ +#!./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 new file mode 100755 index 0000000..bb93d21 --- /dev/null +++ b/contrib/perl5/t/comp/cpp.aux @@ -0,0 +1,39 @@ +#!./perl -P + +# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $ + +print "1..3\n"; + +#this is a comment +#define MESS "ok 1\n" +print MESS; + +#If you capitalize, it's a comment. +#ifdef MESS + print "ok 2\n"; +#else + 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 new file mode 100755 index 0000000..86e7359 --- /dev/null +++ b/contrib/perl5/t/comp/cpp.t @@ -0,0 +1,18 @@ +#!./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\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 new file mode 100755 index 0000000..32b8509 --- /dev/null +++ b/contrib/perl5/t/comp/decl.t @@ -0,0 +1,49 @@ +#!./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 new file mode 100755 index 0000000..ed418b8 --- /dev/null +++ b/contrib/perl5/t/comp/multiline.t @@ -0,0 +1,46 @@ +#!./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 new file mode 100755 index 0000000..d7d19ae --- /dev/null +++ b/contrib/perl5/t/comp/package.t @@ -0,0 +1,39 @@ +#!./perl + +print "1..7\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"; diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t new file mode 100755 index 0000000..6a59107 --- /dev/null +++ b/contrib/perl5/t/comp/proto.t @@ -0,0 +1,415 @@ +#!./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..82\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 \&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 $@ !~ /^Cannot 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"; diff --git a/contrib/perl5/t/comp/redef.t b/contrib/perl5/t/comp/redef.t new file mode 100755 index 0000000..07e978b --- /dev/null +++ b/contrib/perl5/t/comp/redef.t @@ -0,0 +1,80 @@ +#!./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 new file mode 100755 index 0000000..203b996 --- /dev/null +++ b/contrib/perl5/t/comp/require.t @@ -0,0 +1,50 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = ('.'); +} + +# don't make this lexical +$i = 1; +print "1..4\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': $!"; + print REQ @_; + close REQ; +} + +# interaction with pod (see the eof) +write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); +require "bleah.pm"; +$i++; + +# run-time failure in require +do_require "0;\n"; +print "# $@\nnot " unless $@ =~ /did not return a true/; +print "ok ",$i++,"\n"; + +# compile-time failure in require +do_require "1)\n"; +print "# $@\nnot " unless $@ =~ /syntax error/i; +print "ok ",$i++,"\n"; + +# successful require +do_require "1"; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +END { unlink 'bleah.pm'; } + +# ***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 new file mode 100755 index 0000000..d0c12e9 --- /dev/null +++ b/contrib/perl5/t/comp/script.t @@ -0,0 +1,27 @@ +#!./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 =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "print ""ok\n""";`; } + +if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} + +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 =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. Comp.script`; } + +if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} + +$x = `$PERL <Comp.script`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; } + +if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} + +unlink 'Comp.script' || `/bin/rm -f Comp.script`; diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t new file mode 100755 index 0000000..eb99680 --- /dev/null +++ b/contrib/perl5/t/comp/term.t @@ -0,0 +1,70 @@ +#!./perl + +# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $ + +# tests that aren't important enough for base.term + +print "1..22\n"; + +$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";} diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t new file mode 100755 index 0000000..a6ce2a4 --- /dev/null +++ b/contrib/perl5/t/comp/use.t @@ -0,0 +1,101 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..14\n"; + +my $i = 1; + +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; # I know that this module will be there. + + +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"; diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness new file mode 100644 index 0000000..f6d94de --- /dev/null +++ b/contrib/perl5/t/harness @@ -0,0 +1,33 @@ +#!./perl + +# We suppose that perl _mostly_ works at this moment, so may use +# sophisticated testing. + +BEGIN { + chdir 't' if -d 't'; + @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'; + +@tests = @ARGV; +@tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests; + +Test::Harness::runtests @tests; + +%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); + +@tests = grep (!$infinite{$_}, @tests); + +if (-e "../testcompile") +{ + print "The tests ", join(' ', keys(%infinite)), + " generate infinite loops! Skipping!\n"; + + $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; +} diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t new file mode 100755 index 0000000..d99865e --- /dev/null +++ b/contrib/perl5/t/io/argv.t @@ -0,0 +1,48 @@ +#!./perl + +# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $ + +print "1..5\n"; + +open(try, '>Io.argv.tmp') || (die "Can't open temp file."); +print try "a line\n"; +close try; + +if ($^O eq 'MSWin32') { + $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; +} +else { + $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; +} +if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} + +if ($^O eq 'MSWin32') { + $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`; +} +else { + $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.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.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.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";} + +unlink 'Io.argv.tmp'; diff --git a/contrib/perl5/t/io/dup.t b/contrib/perl5/t/io/dup.t new file mode 100755 index 0000000..f312671 --- /dev/null +++ b/contrib/perl5/t/io/dup.t @@ -0,0 +1,39 @@ +#!./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 new file mode 100755 index 0000000..164a667 --- /dev/null +++ b/contrib/perl5/t/io/fs.t @@ -0,0 +1,159 @@ +#!./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 'dos' or $^O eq 'os2'); + +# avoid win32 (for now) +do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; + +print "1..26\n"; + +$wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); +chop($wd); + +if ($^O eq 'MSWin32') { `del tmp`; `mkdir tmp`; } +else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } +chdir './tmp'; +`/bin/rm -rf a b c x` if -x '/bin/rm'; + +umask(022); + +if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +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";} + +if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} +elsif (($mode & 0777) == 0777) {print "ok 7\n";} +else {print "not ok 7\n";} + +if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} +elsif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} +else {print "not ok 8\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {print "ok 9\n";} +else {print "not ok 9\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('x'); +if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} +elsif (($mode & 0777) == 0700) {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 +$foo = (utime 500000000,500000000 + $delta,'b'); +if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} +if ($wd =~ m#/afs/# || $^O eq 'amigaos') + {print "ok 18 # skipped: granularity of the filetime\n";} +elsif ($atime == 500000000 && $mtime == 500000000 + $delta) + {print "ok 18\n";} +else + {print "not ok 18 $atime $mtime\n";} + +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"; +rmdir 'tmp'; + +unlink 'c'; +if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { + # we have symbolic links + if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";} + $foo = `grep perl c`; + if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} + unlink 'c'; +} +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"; + { select FH; $| = 1; select STDOUT } + print FH "helloworld\n"; + truncate FH, 5; + if ($^O eq 'dos') { + close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; + } + if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} + truncate FH, 0; + if ($^O eq 'dos') { + close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; + } + if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} + close FH; +} +unlink "Iofs.tmp"; diff --git a/contrib/perl5/t/io/inplace.t b/contrib/perl5/t/io/inplace.t new file mode 100755 index 0000000..ff410a7 --- /dev/null +++ b/contrib/perl5/t/io/inplace.t @@ -0,0 +1,36 @@ +#!./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 new file mode 100755 index 0000000..10a5c5f --- /dev/null +++ b/contrib/perl5/t/io/iprefix.t @@ -0,0 +1,36 @@ +#!./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/pipe.t b/contrib/perl5/t/io/pipe.t new file mode 100755 index 0000000..ba7a9b0 --- /dev/null +++ b/contrib/perl5/t/io/pipe.t @@ -0,0 +1,135 @@ +#!./perl + +# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } +} + +$| = 1; +print "1..12\n"; + +open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); +print PIPE "Xk 1\n"; +print PIPE "oY 2\n"; +close PIPE; + +if (open(PIPE, "-|")) { + while(<PIPE>) { + s/^not //; + print; + } + close PIPE; # avoid zombies which disrupt test 12 +} +else { + print STDOUT "not ok 3\n"; + exec 'echo', 'not ok 4'; +} + +pipe(READER,WRITER) || die "Can't open pipe"; + +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; + exec 'echo', 'not ok 6'; +} + + +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\n"; + print "ok 10\n"; + print "ok 11\n"; + print "ok 12\n"; + exit; +} + +if ($Config{d_sfio} || $^O eq machten || $^O eq beos) { + # Sfio doesn't report failure when closing a broken pipe + # that has pending output. Go figure. MachTen doesn't either, + # but won't write to broken pipes, so nothing's pending at close. + # BeOS will not write to broken pipes, either. + print "ok 9\n"; +} +else { + local $SIG{PIPE} = 'IGNORE'; + open NIL, '|true' or die "open failed: $!"; + sleep 2; + print NIL 'foo' or die "print failed: $!"; + if (close NIL) { + print "not ok 9\n"; + } + else { + print "ok 9\n"; + } +} + +# 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"; +} + +# check that status for the correct process is collected +wait; # Collect from $pid +my $zombie = fork or exit 37; +my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; +$SIG{ALRM} = sub { return }; +alarm(1); +my $close = close FH; +if ($? == 13*256 && ! length $close && ! $!) { + print "ok 11\n"; +} else { + print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; +}; +my $wait = wait; +if ($? == 37*256 && $wait == $zombie && ! $!) { + print "ok 12\n"; +} else { + print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; +} diff --git a/contrib/perl5/t/io/print.t b/contrib/perl5/t/io/print.t new file mode 100755 index 0000000..180b1e8 --- /dev/null +++ b/contrib/perl5/t/io/print.t @@ -0,0 +1,32 @@ +#!./perl + +# $RCSfile: print.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:32 $ + +print "1..16\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; diff --git a/contrib/perl5/t/io/read.t b/contrib/perl5/t/io/read.t new file mode 100755 index 0000000..b27fde1 --- /dev/null +++ b/contrib/perl5/t/io/read.t @@ -0,0 +1,26 @@ +#!./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 new file mode 100755 index 0000000..83904e8 --- /dev/null +++ b/contrib/perl5/t/io/tell.t @@ -0,0 +1,44 @@ +#!./perl + +# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $ + +print "1..13\n"; + +$TST = 'tst'; + +open($TST, '../Configure') || (die "Can't open ../Configure"); +binmode $TST if $^O eq 'MSWin32'; +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"; } diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t new file mode 100755 index 0000000..fb5a984 --- /dev/null +++ b/contrib/perl5/t/lib/abbrev.t @@ -0,0 +1,51 @@ +#!./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/anydbm.t b/contrib/perl5/t/lib/anydbm.t new file mode 100755 index 0000000..0391b7b --- /dev/null +++ b/contrib/perl5/t/lib/anydbm.t @@ -0,0 +1,125 @@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} +require AnyDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..12\n"; + +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 ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $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"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +if ($^O eq 'VMS') { + unlink 'Op_dbmx.sdbm_dir', $Dfile; +} else { + unlink 'Op_dbmx.dir', $Dfile; +} diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t new file mode 100755 index 0000000..b1622a8 --- /dev/null +++ b/contrib/perl5/t/lib/autoloader.t @@ -0,0 +1,100 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + $dir = "auto-$$"; + @INC = ("./$dir", "../lib"); +} + +print "1..9\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"; + +# 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"; +rmdir "$dir/auto/Foo"; +rmdir "$dir/auto"; +rmdir "$dir"; +} diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t new file mode 100755 index 0000000..a02aa32 --- /dev/null +++ b/contrib/perl5/t/lib/basename.t @@ -0,0 +1,139 @@ +#!./perl -T + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Basename qw(fileparse basename dirname); + +print "1..36\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:') eq 'arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n"; + + +# Check quoting of metacharacters in suffix arg by basename() +print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? + '' : 'not '),"ok 29\n"; +print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? + '' : 'not '),"ok 30\n"; + +# extra tests for a few specific bugs + +File::Basename::fileparse_set_fstype 'MSDOS'; +# perl5.003_18 gives C:/perl/.\ +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +# perl5.003_18 gives C:\perl\ +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; + +File::Basename::fileparse_set_fstype 'UNIX'; +# perl5.003_18 gives '.' +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +# perl5.003_18 gives '/perl/lib' +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\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 35\n"; +print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) + ? '' : 'not '), "ok 36\n"; diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t new file mode 100755 index 0000000..034c5c6 --- /dev/null +++ b/contrib/perl5/t/lib/bigint.t @@ -0,0 +1,282 @@ +#!./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 new file mode 100755 index 0000000..e7cac26 --- /dev/null +++ b/contrib/perl5/t/lib/bigintpm.t @@ -0,0 +1,313 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::BigInt; + +$test = 0; +$| = 1; +print "1..247\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);"; + } 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"; + } + } +} +__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:NaN +abc:+0:NaN ++0:abc:NaN ++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 diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t new file mode 100755 index 0000000..86df161 --- /dev/null +++ b/contrib/perl5/t/lib/cgi-form.t @@ -0,0 +1,81 @@ +#!./perl + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +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"); +} + +# 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\n), + "checkbox()"); +test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast\n), + "checkbox()"); +test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast\n), + "checkbox()"); +test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast\n), + "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 VALUE="chess">chess +<OPTION SELECTED VALUE="cribbage">cribbage +</SELECT> +END + diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t new file mode 100755 index 0000000..ad8b968 --- /dev/null +++ b/contrib/perl5/t/lib/cgi-function.t @@ -0,0 +1,85 @@ +#!./perl + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$| = 1; print "1..24\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"); +} + +# 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'); + +if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { + for (23,24) { print "ok $_ # Skipped: fork n/a\n" } +} +else { + CGI::_reset_globals; + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t new file mode 100755 index 0000000..16aa824 --- /dev/null +++ b/contrib/perl5/t/lib/cgi-html.t @@ -0,0 +1,66 @@ +#!./perl + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$| = 1; print "1..17\n"; } +BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; + $eol = "\r\n" if $^O eq 'os390'; } +END {print "not ok 1\n" unless $loaded;} +use CGI (':standard','-no_debug'); +$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,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${eol}${eol}","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${eol}${eol}","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${eol}Content-Type: image/gif${eol}${eol}","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${eol}Content-Type: text/html${eol}${eol}","header()"); +test(13,start_html() ."\n" eq <<END,"start_html()"); +<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> +<HTML><HEAD><TITLE>Untitled Document</TITLE> +</HEAD><BODY> +END + ; +test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); +<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR"> +<HTML><HEAD><TITLE>Untitled Document</TITLE> +</HEAD><BODY> +END + ; +test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); +<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> +<HTML><HEAD><TITLE>The world of foo</TITLE> +</HEAD><BODY> +END + ; +test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq + 'fred=chocolate&chip; path=/',"cookie()"); +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, + "header(-cookie)"); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t new file mode 100755 index 0000000..8c70c40 --- /dev/null +++ b/contrib/perl5/t/lib/cgi-request.t @@ -0,0 +1,93 @@ +#!./perl + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$| = 1; print "1..31\n"; } +END {print "not ok 1\n" unless $loaded;} +use Config; +use CGI (); +$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{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"); + +if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { + for (29..31) { print "ok $_ # Skipped: fork n/a\n" } +} +else { + $q->_reset_globals; + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(29,$q=new CGI,"CGI::new() from POST"); + test(30,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(31,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t new file mode 100755 index 0000000..b5426ca --- /dev/null +++ b/contrib/perl5/t/lib/checktree.t @@ -0,0 +1,19 @@ +#!./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/complex.t b/contrib/perl5/t/lib/complex.t new file mode 100755 index 0000000..2bb14f0 --- /dev/null +++ b/contrib/perl5/t/lib/complex.t @@ -0,0 +1,879 @@ +#!./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; + +$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/); + +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-11; # 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 '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 '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 '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'; +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'; +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)', + 'atan($i)', +# 'atanh(-1)', # Log of zero. + 'atanh(+1)', + 'cot(0)', + 'coth(0)', + 'csc(0)', + 'tan($pip2)', + 'csch(0)', + 'tan($pip2)', + ); + +test_loz( + 'log($zero)', + 'acot(-$i)', + 'atanh(-1)', + 'acoth(-1)', + ); + +# test the 0**0 + +sub test_ztz { + $test++; + + push(@script, <<'EOT'); +eval 'cplx(0)**cplx(0)'; +print 'not ' unless ($@ =~ /zero raised to the zeroth/); +EOT + push(@script, qq(print "ok $test\\n";\n)); +} + +test_ztz; + +# test the bad roots + +sub test_broot { + for my $op (@_) { + $test++; + + push(@script, <<EOT); +eval 'root(2, $op)'; +print 'not ' unless (\$@ =~ /root must be/); +EOT + push(@script, qq(print "ok $test\\n";\n)); + } +} + +test_broot(qw(-3 -2.1 0 0.99)); + +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) + +&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 new file mode 100755 index 0000000..bf739c8 --- /dev/null +++ b/contrib/perl5/t/lib/db-btree.t @@ -0,0 +1,612 @@ +#!./perl -w + +BEGIN { + @INC = '../lib' if -d '../lib' ; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; + +print "1..102\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 ; +} + +$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 '$q = $dbh->{fred}' ; +ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; + +# Now check the interface to BTREE + +ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); + +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'); + +@keys = keys(%h); +@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 '' ) ; + +#$h{''} = 'bar'; +#ok(32, $h{''} eq 'bar' ); +ok(32,1) ; + +# 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; } +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; +@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. + +$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 ); +#$status = $X->del('') ; +#ok(42, $status == 0 ); +ok(42,1) ; + +# 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 ); +$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 +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 ; +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 +$Dfile1 = "btree1" ; +$Dfile2 = "btree2" ; +$Dfile3 = "btree3" ; + +$dbh1 = new DB_File::BTREEINFO ; +{ local $^W = 0 ; + $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } + +$dbh2 = new DB_File::BTREEINFO ; +$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; + +$dbh3 = new DB_File::BTREEINFO ; +$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; + + +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; +tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; + +@Keys = qw( 0123 12 -1234 9 987654321 def ) ; +{ local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; } +@srt_2 = sort { $a cmp $b } @Keys ; +@srt_3 = sort { length $a <=> length $b } @Keys ; + +foreach (@Keys) { + { local $^W = 0 ; + $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 strict ; + + 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 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" ; + +} + +exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t new file mode 100755 index 0000000..e748472 --- /dev/null +++ b/contrib/perl5/t/lib/db-hash.t @@ -0,0 +1,416 @@ +#!./perl -w + +BEGIN { + @INC = '../lib' if -d '../lib' ; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; + +print "1..62\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +$Dfile = "dbhash.tmp"; +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 + +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); + +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'); + +@keys = keys(%h); +@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 '' ); + +#$h{''} = 'bar'; +#ok(27, $h{''} eq 'bar' ); +ok(27,1) ; + +# 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; } +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; +@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. + +$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 +$^W = 0 ; +ok(37, $h{'q'} eq undef ); +$^W = 1 ; + +# 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 strict ; + + 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 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" ; + +} +exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t new file mode 100755 index 0000000..c89c3ca --- /dev/null +++ b/contrib/perl5/t/lib/db-recno.t @@ -0,0 +1,453 @@ +#!./perl -w + +BEGIN { + @INC = '../lib' if -d '../lib' ; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; +use strict ; +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 ; +} + +sub bad_one +{ + print STDERR <<EOM unless $bad_ones++ ; +# +# Some older versions of Berkeley DB will fail tests 51, 53 and 55. +# +# You can safely ignore the errors if you're never going to use the +# broken functionality (recno databases with a modified bval). +# Otherwise you'll have to upgrade your DB library. +# +# If you want to upgrade Berkeley DB, the most recent version is 1.85. +# Check out http://www.bostic.com/db for more details. +# +EOM +} + +print "1..78\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; + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + + +{ + # Check bval defaults to \n + + 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 strict ; + + 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 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; + + +} + +exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t new file mode 100755 index 0000000..aa7be35 --- /dev/null +++ b/contrib/perl5/t/lib/dirhand.t @@ -0,0 +1,33 @@ +#!./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 new file mode 100755 index 0000000..577d4ea --- /dev/null +++ b/contrib/perl5/t/lib/dosglob.t @@ -0,0 +1,112 @@ +#!./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 array 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/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t new file mode 100755 index 0000000..db4a5d9 --- /dev/null +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -0,0 +1,30 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +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 new file mode 100755 index 0000000..70f8abe --- /dev/null +++ b/contrib/perl5/t/lib/dumper.t @@ -0,0 +1,611 @@ +#!./perl -w +# +# testsuite for Data::Dumper +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +use Data::Dumper; + +$Data::Dumper::Pad = "#"; +my $TMAX; +my $XS; +my $TNUM = 0; +my $WANT = ''; + +sub TEST { + my $string = shift; + my $t = eval $string; + ++$TNUM; + 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; + print( ($t eq $WANT and not $@) ? "ok $TNUM\n" + : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); +} + +if (defined &Data::Dumper::Dumpxs) { + print "### XS extension loaded, will run XS tests\n"; + $TMAX = 138; $XS = 1; +} +else { + print "### XS extensions not loaded, will NOT run XS tests\n"; + $TMAX = 69; $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\000\efg" => "mno\000" +#}; +EOT + +$foo = { "abc\000\efg" => "mno\000" }; +{ + local $Data::Dumper::Useqq = 1; + TEST q(Dumper($foo)); +} + + $WANT = <<"EOT"; +#\$VAR1 = { +# 'abc\000\efg' => 'mno\000' +#}; +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 +# '', +# #2 +# { +# 'a' => 1, +# 'b' => '', +# '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, +# '', +# { +# 'a' => 1, +# 'b' => '', +# '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' => '', +# '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' => '', +# '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 a { print "foo\n" } +$c = [ \&a ]; + +############# 121 +## + $WANT = <<'EOT'; +#$a = $b; +#$c = [ +# $b +#]; +EOT + +TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dump;); +TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) + if $XS; + +############# 127 +## + $WANT = <<'EOT'; +#$a = \&b; +#$c = [ +# \&b +#]; +EOT + +TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dump;); +TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) + if $XS; + +############# 133 +## + $WANT = <<'EOT'; +#*a = \&b; +#@c = ( +# \&b +#); +EOT + +TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dump;); +TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dumpxs;) + if $XS; + +} diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t new file mode 100755 index 0000000..9691229 --- /dev/null +++ b/contrib/perl5/t/lib/english.t @@ -0,0 +1,47 @@ +#!./perl + +print "1..16\n"; + +BEGIN { @INC = '../lib' } +use English; +use Config; +my $threads = $Config{'usethreads'} || 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 == $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.t b/contrib/perl5/t/lib/env.t new file mode 100755 index 0000000..5a82207 --- /dev/null +++ b/contrib/perl5/t/lib/env.t @@ -0,0 +1,18 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +BEGIN { + $ENV{FOO} = "foo"; +} + +use Env qw(FOO); + +$FOO .= "/bar"; + +print "1..1\n"; +print "not " if $FOO ne 'foo/bar'; +print "ok 1\n"; diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t new file mode 100755 index 0000000..361723f --- /dev/null +++ b/contrib/perl5/t/lib/errno.t @@ -0,0 +1,50 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../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/fields.t b/contrib/perl5/t/lib/fields.t new file mode 100755 index 0000000..139e469 --- /dev/null +++ b/contrib/perl5/t/lib/fields.t @@ -0,0 +1,112 @@ +#!./perl -w + +my $w; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print $_[0]; + }; +} + +use strict; +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); + +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)+3, "\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 field "notthere"/; +print "ok ", ++$testno, "\n"; + +#fields::_dump(); diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t new file mode 100755 index 0000000..a97fdd5 --- /dev/null +++ b/contrib/perl5/t/lib/filecache.t @@ -0,0 +1,25 @@ +#!./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 new file mode 100755 index 0000000..329931f --- /dev/null +++ b/contrib/perl5/t/lib/filecopy.t @@ -0,0 +1,90 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +$| = 1; + +use File::Copy; + +# First we create a file +open(F, ">file-$$") or die; +binmode F; # for DOSISH platforms, because test 3 copies to stdout +print F "ok 3\n"; +close F; + +copy "file-$$", "copy-$$"; + +open(F, "copy-$$") or die; +$foo = <F>; +close(F); + +print "not " if -s "file-$$" != -s "copy-$$"; +print "ok 1\n"; + +print "not " unless $foo eq "ok 3\n"; +print "ok 2\n"; + +binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode +copy "copy-$$", \*STDOUT; +unlink "copy-$$" or die "unlink: $!"; + +open(F,"file-$$"); +copy(*F, "copy-$$"); +open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 4\n"; +unlink "copy-$$" or die "unlink: $!"; +open(F,"file-$$"); +copy(\*F, "copy-$$"); +close(F) or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; +print "not " unless $foo eq "ok 3\n"; +print "ok 5\n"; +unlink "copy-$$" or die "unlink: $!"; + +require IO::File; +$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 6\n"; +unlink "copy-$$" or die "unlink: $!"; +require FileHandle; +my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 7\n"; +unlink "file-$$" or die "unlink: $!"; + +print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); +print "# target disappeared.\nnot " if not -e "copy-$$"; +print "ok 8\n"; + +move "copy-$$", "file-$$" or print "# move did not succeed.\n"; +print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; +open(R, "file-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 9\n"; + +copy "file-$$", "lib"; +open(R, "lib/file-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 10\n"; +unlink "lib/file-$$" or die "unlink: $!"; + +move "file-$$", "lib"; +open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; +print "ok 11\n"; +unlink "lib/file-$$" or die "unlink: $!"; + diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t new file mode 100755 index 0000000..cd2e977 --- /dev/null +++ b/contrib/perl5/t/lib/filefind.t @@ -0,0 +1,14 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..2\n"; + +use File::Find; + +# hope we will eventually find ourself +find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); +finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t new file mode 100755 index 0000000..b8ec95f --- /dev/null +++ b/contrib/perl5/t/lib/filehand.t @@ -0,0 +1,90 @@ +#!./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') { + $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 new file mode 100755 index 0000000..c3bf4a4 --- /dev/null +++ b/contrib/perl5/t/lib/filepath.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Path; +use strict; + +my $count = 0; +$^W = 1; + +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 new file mode 100755 index 0000000..ca22d3e --- /dev/null +++ b/contrib/perl5/t/lib/filespec.t @@ -0,0 +1,43 @@ +#!./perl + +BEGIN { + $^O = ''; + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +use File::Spec; + + +if (File::Spec->catfile('a','b','c') eq 'a/b/c') { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} + +use File::Spec::OS2; + +if (File::Spec::OS2->catfile('a','b','c') eq 'a/b/c') { + print "ok 2\n"; +} else { + print "not ok 2\n"; +} + +use File::Spec::Win32; + +if (File::Spec::Win32->catfile('a','b','c') eq 'a\b\c') { + print "ok 3\n"; +} else { + print "not ok 3\n"; +} + +use File::Spec::Mac; + +if (File::Spec::Mac->catfile('a','b','c') eq 'a:b:c') { + print "ok 4\n"; +} else { + print "not ok 4\n"; +} + diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t new file mode 100755 index 0000000..3e742f9 --- /dev/null +++ b/contrib/perl5/t/lib/findbin.t @@ -0,0 +1,13 @@ +#!./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/gdbm.t b/contrib/perl5/t/lib/gdbm.t new file mode 100755 index 0000000..2395611 --- /dev/null +++ b/contrib/perl5/t/lib/gdbm.t @@ -0,0 +1,208 @@ +#!./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\n"; + exit 0; + } +} + +use GDBM_File; + +print "1..20\n"; + +unlink <Op.dbmx*>; + +umask(0); +print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$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 { + ($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\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'}; + +@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"); +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 ; + + 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, '.'; } + + 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*> ; + +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t new file mode 100755 index 0000000..fb70f10 --- /dev/null +++ b/contrib/perl5/t/lib/getopt.t @@ -0,0 +1,73 @@ +#!./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/h2ph.h b/contrib/perl5/t/lib/h2ph.h new file mode 100644 index 0000000..cddf0a7 --- /dev/null +++ b/contrib/perl5/t/lib/h2ph.h @@ -0,0 +1,85 @@ +/* + * 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 new file mode 100644 index 0000000..80867a6 --- /dev/null +++ b/contrib/perl5/t/lib/h2ph.pht @@ -0,0 +1,69 @@ +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 new file mode 100755 index 0000000..1fa7f63 --- /dev/null +++ b/contrib/perl5/t/lib/h2ph.t @@ -0,0 +1,34 @@ +#!./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"); +} diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t new file mode 100755 index 0000000..e4ac365 --- /dev/null +++ b/contrib/perl5/t/lib/hostname.t @@ -0,0 +1,19 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Sys::Hostname; + +eval { + $host = hostname; +}; + +if ($@) { + print "1..0\n" if $@ =~ /Cannot get host name/; +} else { + print "1..1\n"; + print "ok 1\n"; +} diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t new file mode 100755 index 0000000..6b0caf1 --- /dev/null +++ b/contrib/perl5/t/lib/io_dup.t @@ -0,0 +1,61 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; +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_pipe.t b/contrib/perl5/t/lib/io_pipe.t new file mode 100755 index 0000000..e617c92 --- /dev/null +++ b/contrib/perl5/t/lib/io_pipe.t @@ -0,0 +1,117 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if (! $Config{'d_fork'} || + ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) + { + print "1..0\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_sel.t b/contrib/perl5/t/lib/io_sel.t new file mode 100755 index 0000000..3dc651b --- /dev/null +++ b/contrib/perl5/t/lib/io_sel.t @@ -0,0 +1,116 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..21\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"; diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t new file mode 100755 index 0000000..8fc52e4 --- /dev/null +++ b/contrib/perl5/t/lib/io_sock.t @@ -0,0 +1,91 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if (-d "lib" && -f "TEST") { + if (!$Config{'d_fork'} || + (($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket}))) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + ) 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(); + 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) { + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. + + $sock = IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => 'localhost' + ) + or die "$! (maybe your system does not have the 'localhost' address defined)"; + + $sock->autoflush(1); + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} + + + + + + diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t new file mode 100755 index 0000000..0ef2cfd --- /dev/null +++ b/contrib/perl5/t/lib/io_taint.t @@ -0,0 +1,48 @@ +#!./perl -T + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +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 new file mode 100755 index 0000000..2009d61 --- /dev/null +++ b/contrib/perl5/t/lib/io_tell.t @@ -0,0 +1,64 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../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 new file mode 100755 index 0000000..014e12d --- /dev/null +++ b/contrib/perl5/t/lib/io_udp.t @@ -0,0 +1,48 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..3\n"; + +use Socket; +use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. + +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; + +print "ok 1\n"; + +$udpa->send("ok 2\n",0,$udpb->sockname); +$udpb->recv($buf="",5); +print $buf; +$udpb->send("ok 3\n"); +$udpa->recv($buf="",5); +print $buf; diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t new file mode 100755 index 0000000..1a6fd38 --- /dev/null +++ b/contrib/perl5/t/lib/io_xs.t @@ -0,0 +1,42 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::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 new file mode 100755 index 0000000..30ea48d --- /dev/null +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -0,0 +1,178 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + + @INC = '../lib'; + + require Config; import Config; + + unless ($Config{'d_msg'} eq 'define' && + $Config{'d_sem'} eq 'define') { + print "1..0\n"; + exit; + } +} + +# These constants are common to all tests. +# Later the sem* tests will import more for themselves. + +use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID + S_IRWXU S_IRWXG S_IRWXO); +use 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); +}; + +if ($Config{'d_msgget'} eq 'define' && + $Config{'d_msgctl'} eq 'define' && + $Config{'d_msgsnd'} eq 'define' && + $Config{'d_msgrcv'} eq 'define') { + $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO); + # 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"; + + msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; + print "ok 2\n"; + + 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; + msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not "; + print "ok 5\n"; + + my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); + + print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); + print "ok 6\n"; +} else { + for (1..6) { + print "ok $_\n"; # fake it + } +} + +if($Config{'d_semget'} eq 'define' && + $Config{'d_semctl'} eq 'define') { + + use IPC::SysV qw(IPC_CREAT GETALL SETALL); + + $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT); + # Very first time called after machine is booted value may be 0 + die "semget: $!\n" unless defined($sem) && $sem >= 0; + + 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 $template; + + # Find the pack/unpack template capable of handling native C shorts. + + if ($Config{shortsize} == 2) { + $template = "s"; + } elsif ($Config{shortsize} == 4) { + $template = "l"; + } elsif ($Config{shortsize} == 8) { + # Try quad last because not supported everywhere. + foreach my $t (qw(i q)) { + # We could trap the unsupported quad template with eval + # but if we get this far we should have quad support anyway. + if (length(pack($t, 0)) == 8) { + $template = $t; + last; + } + } + } + + die "$0: cannot pack native shorts\n" unless defined $template; + + $template .= "*"; + + my $nsem = 10; + + semctl($sem,0,SETALL,pack($template,(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($template,(0) x $nsem)); + print "ok 12\n"; + + my @data = unpack($template,$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($template,@data)) or print "not "; + print "ok 14\n"; + + $data = ""; + semctl($sem,0,GETALL,$data) or print "not "; + print "ok 15\n"; + + @data = unpack($template,$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 $_\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 new file mode 100755 index 0000000..a97dbd1 --- /dev/null +++ b/contrib/perl5/t/lib/ndbm.t @@ -0,0 +1,207 @@ +#!./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\n"; + exit 0; + } +} + +require NDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..18\n"; + +unlink <Op.dbmx*>; + +umask(0); +print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$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 { + ($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\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'}; + +@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"); +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 ; + + 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 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*> ; + +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t new file mode 100755 index 0000000..8ba9bcf --- /dev/null +++ b/contrib/perl5/t/lib/odbm.t @@ -0,0 +1,207 @@ +#!./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\n"; + exit 0; + } +} + +require ODBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..18\n"; + +unlink <Op.dbmx*>; + +umask(0); +print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$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 { + ($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\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'}; + +@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"); +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 ; + + 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 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*> ; + +} diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t new file mode 100755 index 0000000..a785fce --- /dev/null +++ b/contrib/perl5/t/lib/opcode.t @@ -0,0 +1,115 @@ +#!./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 new file mode 100755 index 0000000..85b807c --- /dev/null +++ b/contrib/perl5/t/lib/open2.t @@ -0,0 +1,59 @@ +#!./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 new file mode 100755 index 0000000..b84dac9 --- /dev/null +++ b/contrib/perl5/t/lib/open3.t @@ -0,0 +1,136 @@ +#!./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 = './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') { + 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..21\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; diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t new file mode 100755 index 0000000..56b1bac --- /dev/null +++ b/contrib/perl5/t/lib/ops.t @@ -0,0 +1,29 @@ +#!./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 new file mode 100755 index 0000000..9079179 --- /dev/null +++ b/contrib/perl5/t/lib/parsewords.t @@ -0,0 +1,103 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Text::ParseWords; + +print "1..17\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 +local($^W) = 0; + +# Test quotewords() with other parameters and null last field +@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); +print "ok 4\n"; + +$^W = 1; + +# Test $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 +$^W = 0; + +@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"; + +$^W = 1; + +# 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"; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t new file mode 100755 index 0000000..de27dee --- /dev/null +++ b/contrib/perl5/t/lib/ph.t @@ -0,0 +1,96 @@ +#!./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 new file mode 100755 index 0000000..8dafc80 --- /dev/null +++ b/contrib/perl5/t/lib/posix.t @@ -0,0 +1,101 @@ +#!./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..18\n"; + +$Is_W32 = $^O eq 'MSWin32'; + +$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); + +@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) { + for (6..11) { + print "ok $_ # skipped, no sigaction support on win32\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'); + 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()); + +$| = 0; +# The following line assumes buffered output, which may be not true with EMX: +print '@#!*$@(!@#$' unless $^O eq 'os2'; +_exit(0); diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t new file mode 100755 index 0000000..27993d9 --- /dev/null +++ b/contrib/perl5/t/lib/safe1.t @@ -0,0 +1,68 @@ +#!./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 new file mode 100755 index 0000000..c9e3880 --- /dev/null +++ b/contrib/perl5/t/lib/safe2.t @@ -0,0 +1,146 @@ +#!./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'; +} + +# 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{archname} =~ /-thread$/; + +$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'); +print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || + $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Invalid argument/ || + $! =~ /Device not configured/ ? + "ok $t\n" : "not ok $t # $!\n"); $t++; +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 new file mode 100755 index 0000000..591fe14 --- /dev/null +++ b/contrib/perl5/t/lib/sdbm.t @@ -0,0 +1,212 @@ +#!./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; + } +} +require SDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..18\n"; + +unlink <Op_dbmx.*>; + +umask(0); +print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) + ? "ok 1\n" : "not ok 1\n"); + +$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 { + ($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\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'}; + +@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"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +if ($^O eq 'VMS') { + unlink 'Op_dbmx.sdbm_dir', $Dfile; +} else { + unlink 'Op_dbmx.dir', $Dfile; +} + + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + 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 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.*> ; + +} diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t new file mode 100755 index 0000000..447c425 --- /dev/null +++ b/contrib/perl5/t/lib/searchdict.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\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, "abash"; +chomp($word = <DICT>); +print "not " if $pos < 0 || $word ne "abash"; +print "ok 1\n"; + +$pos = look *DICT, "foo"; +chomp($word = <DICT>); + +print "not " if $pos != length($DICT); # will search to end of file +print "ok 2\n"; + +$pos = look *DICT, "aarhus", 1, 1; +chomp($word = <DICT>); + +print "not " if $pos < 0 || $word ne "Aarhus"; +print "ok 3\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 new file mode 100755 index 0000000..3b58d70 --- /dev/null +++ b/contrib/perl5/t/lib/selectsaver.t @@ -0,0 +1,28 @@ +#!./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/socket.t b/contrib/perl5/t/lib/socket.t new file mode 100755 index 0000000..4e38295 --- /dev/null +++ b/contrib/perl5/t/lib/socket.t @@ -0,0 +1,76 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../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..6\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"; +} diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t new file mode 100755 index 0000000..d35f264 --- /dev/null +++ b/contrib/perl5/t/lib/soundex.t @@ -0,0 +1,143 @@ +#!./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 new file mode 100755 index 0000000..03449a3 --- /dev/null +++ b/contrib/perl5/t/lib/symbol.t @@ -0,0 +1,52 @@ +#!./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/texttabs.t b/contrib/perl5/t/lib/texttabs.t new file mode 100755 index 0000000..ea9012c --- /dev/null +++ b/contrib/perl5/t/lib/texttabs.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use Text::Tabs; + +$tabstop = 4; + +$s1 = "foo\tbar\tb\tb"; +$s2 = expand $s1; +$s3 = unexpand $s2; + +print "not " unless $s2 eq "foo bar b b"; +print "ok 1\n"; + +print "not " unless $s3 eq "foo bar b\tb"; +print "ok 2\n"; + + +$tabstop = 8; + +print "not " unless unexpand(" foo") eq "\t\t foo"; +print "ok 3\n"; diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t new file mode 100755 index 0000000..9c8d1b4 --- /dev/null +++ b/contrib/perl5/t/lib/textwrap.t @@ -0,0 +1,40 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..5\n"; + +use Text::Wrap qw(wrap $columns); + +$columns = 30; + +$text = <<'EOT'; +Text::Wrap is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line ($initial_tab) and +all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns +should be set to the full width of your output device. +EOT + +$text =~ s/\n/ /g; +$_ = wrap "| ", "|", $text; + +#print "$_\n"; + +print "not " unless /^\| Text::Wrap is/; # start is ok +print "ok 1\n"; + +print "not " if /^.{31,}$/m; # no line longer than 30 chars +print "ok 2\n"; + +print "not " unless /^\|\w/m; # other lines start with +print "ok 3\n"; + +print "not " unless /\bsubsquent\b/; # look for a random word +print "ok 4\n"; + +print "not " unless /\bdevice\./; # look for last word +print "ok 5\n"; diff --git a/contrib/perl5/t/lib/thread.t b/contrib/perl5/t/lib/thread.t new file mode 100755 index 0000000..83407a9 --- /dev/null +++ b/contrib/perl5/t/lib/thread.t @@ -0,0 +1,73 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (! $Config{'usethreads'}) { + print "1..0\n"; + exit 0; + } + + # XXX known trouble with global destruction + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +$| = 1; +print "1..14\n"; +use Thread; +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"); +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 +{ + use attrs '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; + diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t new file mode 100755 index 0000000..dd718de --- /dev/null +++ b/contrib/perl5/t/lib/tie-push.t @@ -0,0 +1,24 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @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 "../t/op/push.t" diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t new file mode 100755 index 0000000..7ca4d76 --- /dev/null +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -0,0 +1,12 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Array; +tie @foo,Tie::StdArray; +tie @ary,Tie::StdArray; +tie @bar,Tie::StdArray; +require "../t/op/array.t" diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t new file mode 100755 index 0000000..34a6947 --- /dev/null +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -0,0 +1,10 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Array; +tie @x,Tie::StdArray; +require "../t/op/push.t" diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t new file mode 100755 index 0000000..100e076 --- /dev/null +++ b/contrib/perl5/t/lib/timelocal.t @@ -0,0 +1,90 @@ +#!./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 new file mode 100755 index 0000000..3114176 --- /dev/null +++ b/contrib/perl5/t/lib/trig.t @@ -0,0 +1,160 @@ +#!./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 ($$;$) { + abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); +} + +print "1..20\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"; +} + +# eof diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t new file mode 100755 index 0000000..d115146 --- /dev/null +++ b/contrib/perl5/t/op/append.t @@ -0,0 +1,21 @@ +#!./perl + +# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ + +print "1..3\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";} diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t new file mode 100755 index 0000000..43af807 --- /dev/null +++ b/contrib/perl5/t/op/arith.t @@ -0,0 +1,12 @@ +#!./perl + +print "1..4\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; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t new file mode 100755 index 0000000..8dea44d --- /dev/null +++ b/contrib/perl5/t/op/array.t @@ -0,0 +1,208 @@ +#!./perl + +print "1..63\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 bar burbl blah); +t("@foo" eq "foo bar burbl 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 +} + diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t new file mode 100755 index 0000000..57e89c4 --- /dev/null +++ b/contrib/perl5/t/op/assignwarn.t @@ -0,0 +1,61 @@ +#!./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; + +$^W = 1; +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..23\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; } + +ok 23, $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/auto.t b/contrib/perl5/t/op/auto.t new file mode 100755 index 0000000..2eb0097 --- /dev/null +++ b/contrib/perl5/t/op/auto.t @@ -0,0 +1,52 @@ +#!./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 new file mode 100755 index 0000000..55cc992 --- /dev/null +++ b/contrib/perl5/t/op/avhv.t @@ -0,0 +1,110 @@ +#!./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..12\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"; + diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t new file mode 100755 index 0000000..b247341 --- /dev/null +++ b/contrib/perl5/t/op/bop.t @@ -0,0 +1,64 @@ +#!./perl + +# +# test the bit operators '&', '|', '^', '~', '<<', and '>>' +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\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; $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"); + diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t new file mode 100755 index 0000000..77263ad --- /dev/null +++ b/contrib/perl5/t/op/chop.t @@ -0,0 +1,87 @@ +#!./perl + +# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ + +print "1..28\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"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t new file mode 100755 index 0000000..95d44f5 --- /dev/null +++ b/contrib/perl5/t/op/closure.t @@ -0,0 +1,482 @@ +#!./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..169\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) +}; + +# 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 new file mode 100755 index 0000000..4a7e68d --- /dev/null +++ b/contrib/perl5/t/op/cmp.t @@ -0,0 +1,35 @@ +#!./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/cond.t b/contrib/perl5/t/op/cond.t new file mode 100755 index 0000000..427efb4 --- /dev/null +++ b/contrib/perl5/t/op/cond.t @@ -0,0 +1,12 @@ +#!./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 new file mode 100755 index 0000000..4625441 --- /dev/null +++ b/contrib/perl5/t/op/context.t @@ -0,0 +1,18 @@ +#!./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 new file mode 100755 index 0000000..33c74ea --- /dev/null +++ b/contrib/perl5/t/op/defins.t @@ -0,0 +1,147 @@ +#!./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 new file mode 100755 index 0000000..6cc4475 --- /dev/null +++ b/contrib/perl5/t/op/delete.t @@ -0,0 +1,51 @@ +#!./perl + +# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ + +print "1..16\n"; + +$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";} +if ($foo{2} eq '') {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";} +if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +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"; diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t new file mode 100755 index 0000000..d473ed6 --- /dev/null +++ b/contrib/perl5/t/op/die.t @@ -0,0 +1,43 @@ +#!./perl + +print "1..10\n"; + +$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; + +$err = "ok 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 new file mode 100755 index 0000000..ffbb1e0 --- /dev/null +++ b/contrib/perl5/t/op/die_exit.t @@ -0,0 +1,53 @@ +#!./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 -e '../lib'; +} +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 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } 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\nnot ", $exit, $bang, $query + 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 new file mode 100755 index 0000000..87ec08d --- /dev/null +++ b/contrib/perl5/t/op/do.t @@ -0,0 +1,44 @@ +#!./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 new file mode 100755 index 0000000..9063c2c --- /dev/null +++ b/contrib/perl5/t/op/each.t @@ -0,0 +1,122 @@ +#!./perl + +# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $ + +print "1..16\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" } diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t new file mode 100755 index 0000000..9368281 --- /dev/null +++ b/contrib/perl5/t/op/eval.t @@ -0,0 +1,81 @@ +#!./perl + +# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $ + +print "1..23\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(); +} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t new file mode 100755 index 0000000..098a455 --- /dev/null +++ b/contrib/perl5/t/op/exec.t @@ -0,0 +1,35 @@ +#!./perl + +# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $ + +$| = 1; # flush stdout + +if ($^O eq 'MSWin32') { + print "# exec is unsupported on Win32\n"; + # XXX the system tests could be written to use ./perl and so work on Win32 + print "1..0\n"; + 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 ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } +print "ok 5\n"; + +if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";} + +unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} + +exec "echo","ok","8"; diff --git a/contrib/perl5/t/op/exp.t b/contrib/perl5/t/op/exp.t new file mode 100755 index 0000000..5efc9ba --- /dev/null +++ b/contrib/perl5/t/op/exp.t @@ -0,0 +1,27 @@ +#!./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/flip.t b/contrib/perl5/t/op/flip.t new file mode 100755 index 0000000..20167f3 --- /dev/null +++ b/contrib/perl5/t/op/flip.t @@ -0,0 +1,29 @@ +#!./perl + +# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ + +print "1..9\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,'../Configure'); +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";} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t new file mode 100755 index 0000000..9790ff0 --- /dev/null +++ b/contrib/perl5/t/op/fork.t @@ -0,0 +1,26 @@ +#!./perl + +# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } +} + +$| = 1; +print "1..2\n"; + +if ($cid = fork) { + sleep 2; + if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} +} +else { + $| = 1; + print "ok 1\n"; + sleep 10; +} diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t new file mode 100755 index 0000000..253e4a3 --- /dev/null +++ b/contrib/perl5/t/op/glob.t @@ -0,0 +1,37 @@ +#!./perl + +# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $ + +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 new file mode 100755 index 0000000..1b34acd --- /dev/null +++ b/contrib/perl5/t/op/goto.t @@ -0,0 +1,90 @@ +#!./perl + +# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $ + +# "This IS structured code. It's just randomly structured." + +print "1..9\n"; + +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'; +$x = `$PERL -e "goto foo;" 2>&1`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; } + +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 9\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"; + +$wherever = FINALE; +goto $wherever; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t new file mode 100755 index 0000000..a35575e --- /dev/null +++ b/contrib/perl5/t/op/goto_xs.t @@ -0,0 +1,98 @@ +#!./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/groups.t b/contrib/perl5/t/op/groups.t new file mode 100755 index 0000000..47aabe3 --- /dev/null +++ b/contrib/perl5/t/op/groups.t @@ -0,0 +1,50 @@ +#!./perl + +if (! -x ($groups = '/usr/ucb/groups') && + ! -x ($groups = '/usr/bin/groups') && + ! -x ($groups = '/bin/groups') +) { + print "1..0\n"; + exit 0; +} + +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, $_); + } +} + +$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 new file mode 100755 index 0000000..c253e4b --- /dev/null +++ b/contrib/perl5/t/op/gv.t @@ -0,0 +1,98 @@ +#!./perl + +# +# various typeglob tests +# + +print "1..23\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 } +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] }; + local $^W = 1; + *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"; + + diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t new file mode 100755 index 0000000..6343a2a --- /dev/null +++ b/contrib/perl5/t/op/hashwarn.t @@ -0,0 +1,71 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +use vars qw{ @warnings }; + +BEGIN { + $^W |= 1; # Insist upon warnings + # ...and save 'em as we go + $SIG{'__WARN__'} = sub { push @warnings, @_ }; + $| = 1; + print "1..7\n"; +} + +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; + + $_ = { 1..10 }; + test 7, ! @warnings, "Unexpected warning"; +} diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t new file mode 100755 index 0000000..e5a2a92 --- /dev/null +++ b/contrib/perl5/t/op/inc.t @@ -0,0 +1,52 @@ +#!./perl + + +# $RCSfile$ + +print "1..6\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";} diff --git a/contrib/perl5/t/op/index.t b/contrib/perl5/t/op/index.t new file mode 100755 index 0000000..0b08f08 --- /dev/null +++ b/contrib/perl5/t/op/index.t @@ -0,0 +1,42 @@ +#!./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 new file mode 100755 index 0000000..eb060ac --- /dev/null +++ b/contrib/perl5/t/op/int.t @@ -0,0 +1,17 @@ +#!./perl + +# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $ + +print "1..4\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";} diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t new file mode 100755 index 0000000..eec4611 --- /dev/null +++ b/contrib/perl5/t/op/join.t @@ -0,0 +1,12 @@ +#!./perl + +# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $ + +print "1..3\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";} diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t new file mode 100755 index 0000000..a4230b6 --- /dev/null +++ b/contrib/perl5/t/op/list.t @@ -0,0 +1,83 @@ +#!./perl + +# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $ + +print "1..27\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; +} + diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t new file mode 100755 index 0000000..2f674d1 --- /dev/null +++ b/contrib/perl5/t/op/local.t @@ -0,0 +1,200 @@ +#!./perl + +# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ + +print "1..58\n"; + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +sub foo { + local($a, $b) = @_; + local($c, $d); + $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"; + diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t new file mode 100755 index 0000000..7f08e06 --- /dev/null +++ b/contrib/perl5/t/op/magic.t @@ -0,0 +1,209 @@ +#!./perl + +BEGIN { + $^W = 1; + $| = 1; + chdir 't' if -d 't'; + @INC = '../lib'; + $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; +} + +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'; +$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`); + } + else { + $wd = '.'; + } + my $perl = "$wd/perl"; + my $headmaybe = ''; + my $tailmaybe = ''; + $script = "$wd/show-shebang"; + if ($Is_MSWin32) { + chomp($wd = `cd`); + $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 + } + if ($^O eq 'os390') { # no shebang + $headmaybe = <<EOH ; + eval 'exec ./perl -S \$0 \${1+"\$\@"}' + if 0; +EOH + } + $s1 = $s2 = "\$^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; + s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl + s{is perl}{is $perl}; # for systems where $^X is only a basename + ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:"; + $_ = `$perl $script`; + s/.exe//i if $Is_Dos; + ok 24, ($Is_MSWin32 ? 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}; + $ENV{foo} = "bar"; + %ENV = (); + $ENV{PATH} = $PATH; + 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 "not " }; + $! = 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",1; + ok "33 # skipped",1; + ok "34 # skipped",1; + ok "35 # skipped",1; +} diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t new file mode 100755 index 0000000..f1b1888 --- /dev/null +++ b/contrib/perl5/t/op/method.t @@ -0,0 +1,128 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..26\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" +} + +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"); diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t new file mode 100755 index 0000000..7292ffe --- /dev/null +++ b/contrib/perl5/t/op/misc.t @@ -0,0 +1,420 @@ +#!./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 { 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/, $_); + if ($^O eq 'MSWin32') { + open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1"; + } + else { + open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + } + print TEST $prog, "\n"; + close TEST; + $status = $?; + $results = `$CAT $tmpfile`; + $results =~ s/\n+$//; + $results =~ s/syntax error/syntax error/i; + $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); +$, = " "; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +EXPECT +7 0 0 1 ! +######## +$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 .= <STDIN>); +######## +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 = <>); +######## +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 deref in repeat 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 at - line 1. +######## +/(?{"{"}})/ # Check it outside of eval too +EXPECT +Unmatched right bracket at (re_eval 1) line 1, at end of line +syntax error at (re_eval 1) line 1, near ""{"}" +Compilation failed in regexp at - line 1. +######## +BEGIN { @ARGV = qw(a b c) } +BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } +END { print "end <",shift,">\nargv <@ARGV>\n" } +INIT { print "init <",shift,">\n" } +EXPECT +argv <a b c> +begin <a> +init <b> +end <c> +argv <> +######## +-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; +select STDERR; $| = 1; print fileno STDERR; +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 +######## diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t new file mode 100755 index 0000000..5ba0a0f --- /dev/null +++ b/contrib/perl5/t/op/mkdir.t @@ -0,0 +1,18 @@ +#!./perl + +# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $ + +print "1..7\n"; + +$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`; + +# tests 3 and 7 rather naughtily expect English error messages +$ENV{'LC_ALL'} = 'C'; + +print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); +print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); +print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); +print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); +print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); +print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); +print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n"); diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t new file mode 100755 index 0000000..1777e88 --- /dev/null +++ b/contrib/perl5/t/op/my.t @@ -0,0 +1,94 @@ +#!./perl + +# $RCSfile: my.t,v $ + +print "1..30\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"; + diff --git a/contrib/perl5/t/op/nothread.t b/contrib/perl5/t/op/nothread.t new file mode 100755 index 0000000..a0d444d --- /dev/null +++ b/contrib/perl5/t/op/nothread.t @@ -0,0 +1,35 @@ +#!./perl + +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + +BEGIN + { + chdir 't' if -d 't'; + @INC = "../lib"; + require Config; + import Config; + if ($Config{'usethreads'}) + { + print "1..0\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/oct.t b/contrib/perl5/t/op/oct.t new file mode 100755 index 0000000..24b5c43 --- /dev/null +++ b/contrib/perl5/t/op/oct.t @@ -0,0 +1,14 @@ +#!./perl + +# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ + +print "1..8\n"; + +print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; +print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; +print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; +print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; +print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; +print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; +print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; +print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t new file mode 100755 index 0000000..ba943f4 --- /dev/null +++ b/contrib/perl5/t/op/ord.t @@ -0,0 +1,18 @@ +#!./perl + +# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $ + +print "1..3\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";} + +# run time evaluation + +$x = 'ABC'; +if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} + +if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t new file mode 100755 index 0000000..9b7bc35 --- /dev/null +++ b/contrib/perl5/t/op/pack.t @@ -0,0 +1,205 @@ +#!./perl + +# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ + +print "1..60\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); +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 ($^O eq 'os390'); # An EBCDIC variant. + +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++ } +{ + local $^W = 1; + 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 + +$in = join "", map { chr } 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"; + +# 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. diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t new file mode 100755 index 0000000..7d4278f --- /dev/null +++ b/contrib/perl5/t/op/pat.t @@ -0,0 +1,597 @@ +#!./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..141\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = "../lib" if -d "../lib"; +} +eval 'use Config'; # Defaults assumed if this fails + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +$x = "abc\ndef\n"; + +if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} +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%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%; +print "ok 69\n"; + +eval "'aaa' =~ /a{1,$reg_infty_p}/"; +print "not " + if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%; +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%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; +print "ok 71\n"; + +# This one will fail when POSIX character classes do get implemented +{ + my $w; + local $^W = 1; + local $SIG{__WARN__} = sub{$w = shift}; + eval q('a' =~ /[[:alpha:]]/); + print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/; +} +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; +} + +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++; + +@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 "not " unless $1 eq $ans; + print "ok $test\n"; + $test++; +} + +$_ = 'a'; +foreach $ans ('', 'a', '') { + /^|a|$/g; + print "not " 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++; + + 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++; +} + +{ + 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 $^W; local %SIG; + eval 'BEGIN { $^W = 1; $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=]]/'); +&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); + +# 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++; + diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t new file mode 100755 index 0000000..46811b7 --- /dev/null +++ b/contrib/perl5/t/op/pos.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\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";} + diff --git a/contrib/perl5/t/op/push.t b/contrib/perl5/t/op/push.t new file mode 100755 index 0000000..a67caed --- /dev/null +++ b/contrib/perl5/t/op/push.t @@ -0,0 +1,56 @@ +#!./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/quotemeta.t b/contrib/perl5/t/op/quotemeta.t new file mode 100755 index 0000000..913e07c --- /dev/null +++ b/contrib/perl5/t/op/quotemeta.t @@ -0,0 +1,38 @@ +#!./perl + +print "1..15\n"; + +if ($^O eq 'os390') { # An EBCDIC variant. + $_=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"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t new file mode 100755 index 0000000..c779f9d --- /dev/null +++ b/contrib/perl5/t/op/rand.t @@ -0,0 +1,348 @@ +#!./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" if -d "../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); + $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 >= (1 << $randbits)) { # Just in case... + print "not 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 "not 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 new file mode 100755 index 0000000..7999b86 --- /dev/null +++ b/contrib/perl5/t/op/range.t @@ -0,0 +1,48 @@ +#!./perl + +print "1..10\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"; + diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests new file mode 100644 index 0000000..a5295f5 --- /dev/null +++ b/contrib/perl5/t/op/re_tests @@ -0,0 +1,485 @@ +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 - /a[b-a]/: invalid [] range in regexp +a[]b - c - /a[]b/: unmatched [] in regexp +a[ - c - /a[/: unmatched [] in regexp +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 - /*a/: ?+*{} follows nothing in regexp +(*)b - c - /(*)b/: ?+*{} follows nothing in regexp +$b b n - - +a\ - c - Search pattern not terminated +a\(b a(b y $&-$1 a(b- +a\(*b ab y $& ab +a\(*b a((b y $& a((b +a\\b a\b y $& a\b +abc) - c - /abc)/: unmatched () in regexp +(abc - c - /(abc/: unmatched () in regexp +((a)) abc y $&-$1-$2 a-a-a +(a)b(c) abc y $&-$1-$2 abc-a-c +a+b+c aabbabc y $& abc +a{1,}b{1,}c aabbabc y $& abc +a** - c - /a**/: nested *?+ in regexp +a.+?c 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 () in regexp +[^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 - /\1/: reference to nonexistent group +\2 - c - /\2/: reference to nonexistent group +(a)|\1 a y - - +(a)|\1 x n - - +(a)|\2 - c - /(a)|\2/: 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 - /a[b-a]/: invalid [] range in regexp +'a[]b'i - c - /a[]b/: unmatched [] in regexp +'a['i - c - /a[/: unmatched [] in regexp +'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 - /*a/: ?+*{} follows nothing in regexp +'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp +'$b'i B n - - +'a\'i - c - Search pattern not terminated +'a\(b'i A(B y $&-$1 A(B- +'a\(*b'i AB y $& AB +'a\(*b'i A((B y $& A((B +'a\\b'i A\B y $& A\B +'abc)'i - c - /abc)/: unmatched () in regexp +'(abc'i - c - /(abc/: unmatched () in regexp +'((a))'i ABC y $&-$1-$2 A-A-A +'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C +'a+b+c'i AABBABC y $& ABC +'a{1,}b{1,}c'i AABBABC y $& ABC +'a**'i - c - /a**/: nested *?+ in regexp +'a.+?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 () in regexp +'[^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 - - +(?:(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 - /(?<%)b/: Sequence (?%...) not recognized +(?:..)*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 - /a(?{)b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{"\{"})b cabd y $& ab +a(?{"{"}})b - c - Unmatched right 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 - /(?(1?)a|b)/: Switch (?(number? not recognized +(?(1)a|b|c) a c - /(?(1)a|b|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 - /[a[:xyz:/: unmatched [] in regexp +[a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp +([a[:xyz:]b]+) pbaq y $1 ba +((?>a+)b) aaab y $1 aaab +(?>(a+))b aaab y $1 aaa +((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x +(?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented +a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +a\Z a\nb\n n - - +b\Z a\nb\n y - - +b\z a\nb\n n - - +b\Z a\nb y - - +b\z a\nb y - - diff --git a/contrib/perl5/t/op/read.t b/contrib/perl5/t/op/read.t new file mode 100755 index 0000000..2746970 --- /dev/null +++ b/contrib/perl5/t/op/read.t @@ -0,0 +1,19 @@ +#!./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 new file mode 100755 index 0000000..ca19ebc --- /dev/null +++ b/contrib/perl5/t/op/readdir.t @@ -0,0 +1,25 @@ +#!./perl + +eval 'opendir(NOSUCH, "no/such/directory");'; +if ($@) { print "1..0\n"; exit; } + +print "1..3\n"; + +if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } +@D = grep(/^[^\.].*\.t$/i, readdir(OP)); +closedir(OP); + +if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } + +@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 new file mode 100755 index 0000000..6594940 --- /dev/null +++ b/contrib/perl5/t/op/recurse.t @@ -0,0 +1,86 @@ +#!./perl + +# +# test recursive functions. +# + +print "1..23\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"; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t new file mode 100755 index 0000000..1d70f9f --- /dev/null +++ b/contrib/perl5/t/op/ref.t @@ -0,0 +1,287 @@ +#!./perl + +print "1..55\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 global destruction + +package FINALE; + +{ + $ref3 = bless ["ok 55\n"]; # package destruction + my $ref2 = bless ["ok 54\n"]; # lexical destruction + local $ref1 = bless ["ok 53\n"]; # dynamic destruction + 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 new file mode 100755 index 0000000..11b3ee3 --- /dev/null +++ b/contrib/perl5/t/op/regexp.t @@ -0,0 +1,97 @@ +#!./perl + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +# The tests are in a separate file 't/op/re_tests'. +# Each line in that file is a separate test. +# There are five columns, separated by tabs. +# +# 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 +# +# 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. +# +# \n in the tests are interpolated, as are variables of the form ${\w+}. +# +# If you want to add a regular expression test that can't be expressed +# in this format, don't add it here: put it in op/pat.t instead. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +$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. + +$| = 1; +print "1..$numtests\n# $iters iterations\n"; +TEST: +while (<TESTS>) { + chomp; + s/\\n/\n/g; + ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); + $input = join(':',$pat,$subject,$result,$repl,$expect); + infty_subst(\$pat); + infty_subst(\$expect); + $pat = "'$pat'" unless $pat =~ /^[:']/; + $pat =~ s/\\n/\n/g; + $pat =~ s/(\$\{\w+\})/$1/eeg; + $subject =~ s/\\n/\n/g; + $expect =~ s/\\n/\n/g; + $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; + 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 ($@) { + 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 new file mode 100755 index 0000000..03c19e9 --- /dev/null +++ b/contrib/perl5/t/op/regexp_noamp.t @@ -0,0 +1,10 @@ +#!./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/repeat.t b/contrib/perl5/t/op/repeat.t new file mode 100755 index 0000000..54fa590 --- /dev/null +++ b/contrib/perl5/t/op/repeat.t @@ -0,0 +1,42 @@ +#!./perl + +# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ + +print "1..19\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"; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t new file mode 100755 index 0000000..307e2a0 --- /dev/null +++ b/contrib/perl5/t/op/runlevel.t @@ -0,0 +1,317 @@ +#!./perl + +## +## Many of these tests are originally from Michael Schroeder +## <Michael.Schroeder@informatik.uni-erlangen.de> +## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## + +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` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './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 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" outside a 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 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 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 diff --git a/contrib/perl5/t/op/sleep.t b/contrib/perl5/t/op/sleep.t new file mode 100755 index 0000000..5f6c4c0 --- /dev/null +++ b/contrib/perl5/t/op/sleep.t @@ -0,0 +1,8 @@ +#!./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 new file mode 100755 index 0000000..70341b9 --- /dev/null +++ b/contrib/perl5/t/op/sort.t @@ -0,0 +1,127 @@ +#!./perl + +# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ + +print "1..21\n"; + +sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } + +my $upperfirst = 'A' lt 'a'; + +# Beware: in future this may become hairier because of possible +# collation complications: qw(A a B c) can be sorted at least as +# any of the following +# +# A a B b +# A B a b +# a b A B +# a A b B +# +# All the above orders make sense. +# +# That said, EBCDIC sorts all small letters first, as opposed +# to ASCII which sorts all big letters first. + +@harry = ('dog','cat','x','Cain','Abel'); +@george = ('gone','chased','yz','punished','Axed'); + +$x = join('', sort @harry); +$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 @george, 'to', @harry); +$expected = $upperfirst ? + 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : + 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 3\n":"not ok 3\n"); + +@a = (); +@b = reverse @a; +print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); + +@a = (1); +@b = reverse @a; +print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); + +@a = (1,2); +@b = reverse @a; +print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); + +@a = (1,2,3); +@b = reverse @a; +print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); + +@a = (1,2,3,4); +@b = reverse @a; +print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); + +@a = (10,2,3,4); +@b = sort {$a <=> $b;} @a; +print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); + +$sub = 'backwards'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 10: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); + +# literals, combinations + +@b = sort (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print "# x = '@b'\n"; + +@b = sort grep { $_ } (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print "# x = '@b'\n"; + +@b = sort map { $_ } (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print "# x = '@b'\n"; + +@b = sort reverse (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print "# x = '@b'\n"; + +$^W = 0; +# redefining sort sub inside the sort sub should fail +sub twoface { *twoface = sub { $a <=> $b }; &twoface } +eval { @b = sort twoface 4,1,3,2 }; +print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); + +# redefining sort subs outside the sort should not fail +eval { *twoface = sub { &backwards } }; +print $@ ? "not ok 16\n" : "ok 16\n"; + +eval { @b = sort twoface 4,1,3,2 }; +print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); + +*twoface = sub { *twoface = *backwards; $a <=> $b }; +eval { @b = sort twoface 4,1 }; +print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); + +*twoface = sub { + eval 'sub twoface { $a <=> $b }'; + die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + $a <=> $b; + }; +eval { @b = sort twoface 4,1 }; +print $@ ? "$@" : "not ok 19\n"; + +eval <<'CODE'; + my @result = sort main'backwards 'one', 'two'; +CODE +print $@ ? "not ok 20\n# $@" : "ok 20\n"; + +eval <<'CODE'; + # "sort 'one', 'two'" should not try to parse "'one" as a sort sub + my @result = sort 'one', 'two'; +CODE +print $@ ? "not ok 21\n# $@" : "ok 21\n"; diff --git a/contrib/perl5/t/op/splice.t b/contrib/perl5/t/op/splice.t new file mode 100755 index 0000000..06e3509 --- /dev/null +++ b/contrib/perl5/t/op/splice.t @@ -0,0 +1,34 @@ +#!./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 new file mode 100755 index 0000000..7f0acce --- /dev/null +++ b/contrib/perl5/t/op/split.t @@ -0,0 +1,113 @@ +#!./perl + +# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ + +print "1..25\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` } +else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } +if ($foo =~ /DCL-W-NOCOMD/) { + $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`; +} +print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n"; + +# 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";} diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t new file mode 100755 index 0000000..b9b4751 --- /dev/null +++ b/contrib/perl5/t/op/sprintf.t @@ -0,0 +1,33 @@ +#!./perl + +# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ + +print "1..4\n"; + +$^W = 1; +$SIG{__WARN__} = sub { + if ($_[0] =~ /^Invalid conversion/) { + $w++; + } else { + warn @_; + } +}; + +$w = 0; +$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999); +if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) { + print "ok 1\n"; +} else { + print "not ok 1 '$x'\n"; +} + +for $i (2 .. 4) { + $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; + $w = 0; + $x = sprintf($f, ''); + if ($x eq $f && $w == 1) { + print "ok $i\n"; + } else { + print "not ok $i '$x' '$f' '$w'\n"; + } +} diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t new file mode 100755 index 0000000..2207b40 --- /dev/null +++ b/contrib/perl5/t/op/stat.t @@ -0,0 +1,252 @@ +#!./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; +chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); + +$DEV = `ls -l /dev` unless $Is_Dosish; + +unlink "Op.stat.tmp"; +open(FOO, ">Op.stat.tmp"); + +# hack to make Apollo update link count: +$junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FOO); +if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} +if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";} +else {print "# |$mtime| vs |$ctime|\nnot ok 2\n";} + +print FOO "Now is the time for all good men to come to.\n"; +close(FOO); + +sleep 2; + +if ($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 + || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug + || $cwd =~ m#/afs/# + || $^O eq 'amigaos') { + print "ok 4 # skipped: different semantic of mtime/ctime\n"; +} +elsif ( ($mtime && $mtime != $ctime) ) { + print "ok 4\n"; +} +else { + 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 :$mtime: should != :$ctime:\n"; + +unlink "Op.stat.tmp"; +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'; +$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 +} + +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 'amigaos' or $Is_Dosish) { + 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; +($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin)) + or print ("not ok 35\n"), goto tty_test; +opendir BIN, $bin or die "Can't opendir $bin: $!"; +while (defined($_ = readdir BIN)) { + $_ = "$bin/$_"; + $cnt++; + $uid++ if -u; + last if $uid && $uid < $cnt; +} +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 { + unless (open(tty,"/dev/tty")) { + print STDERR "Can't open /dev/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); + } + 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'; diff --git a/contrib/perl5/t/op/study.t b/contrib/perl5/t/op/study.t new file mode 100755 index 0000000..ea3b366 --- /dev/null +++ b/contrib/perl5/t/op/study.t @@ -0,0 +1,69 @@ +#!./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 new file mode 100755 index 0000000..afa06ab --- /dev/null +++ b/contrib/perl5/t/op/subst.t @@ -0,0 +1,310 @@ +#!./perl + +print "1..71\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 ($^O eq 'os390') { # An EBCDIC variant. + 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/<$&>/g; +$foo = '<>' . ('<x><>' x 20) ; +print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t new file mode 100755 index 0000000..87efcb4 --- /dev/null +++ b/contrib/perl5/t/op/substr.t @@ -0,0 +1,211 @@ +#!./perl + +print "1..106\n"; + +#P = start of string Q = start of substr R = end of substr S = end of string + +$a = 'abcdefxyz'; +BEGIN { $^W = 1 }; + +$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 fail { !defined(shift) && $w-- }; + +print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S +print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S +print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S +print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S + +$[ = 1; + +print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S +print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S +print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S +print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S + +$[ = 0; + +substr($a,3,3) = 'XYZ'; +print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; +substr($a,0,2) = ''; +print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; +substr($a,0,0) = 'ab'; +print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; +substr($a,0,0) = '12345678'; +print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n"; +substr($a,-3,3) = 'def'; +print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n"; +substr($a,-3,3) = '<'; +print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n"; +substr($a,-1,1) = '12345678'; +print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; + +$a = 'abcdefxyz'; + +print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S +print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S +print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q +print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S +print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S +print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S +print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S + +$a = '54321'; + +print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S +print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S +print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S +print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S +print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S +print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S +print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S +print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S +print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S +print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S +print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S +print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S +print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q +print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q +print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q +print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R + +print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S +print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S +print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S +print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R +print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S +print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S +print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S +print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R +print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S +print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S +print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R +print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S +print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S +print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S +print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S +print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R +print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S +print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S +print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S +print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R +print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S +print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S +print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S +print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S +print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S +print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S + +$a = ''; + +print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S +print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S +print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R +print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R +print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S +print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S + + +print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S +print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S +print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S +print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S +print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S +print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q +print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R +print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R +print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q + + +my $a = 'zxcvbnm'; +substr($a,2,0) = ''; +print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; +substr($a,7,0) = ''; +print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; +substr($a,5,0) = ''; +print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; +substr($a,0,2) = 'pq'; +print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; +substr($a,2,0) = 'r'; +print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; +substr($a,8,0) = 'asd'; +print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; +substr($a,0,2) = 'iop'; +print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; +substr($a,0,5) = 'fgh'; +print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; +substr($a,3,5) = 'jkl'; +print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; +substr($a,3,2) = '1234'; +print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; + + +# with lexicals (and in re-entered scopes) +for (0,1) { + my $txt; + unless ($_) { + $txt = "Foo"; + substr($txt, -1) = "X"; + print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; + } + else { + local $^W = 0; # because of (spurious?) "uninitialised value" + substr($txt, 0, 1) = "X"; + print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; + } +} + +# coercion of references +{ + my $s = []; + substr($s, 0, 1) = 'Foo'; + print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; +} + +# check no spurious warnings +print $w ? "not ok 97\n" : "ok 97\n"; + +# check new 4 arg replacement syntax +$a = "abcxyz"; +$w = 0; +print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +print "ok 98\n"; +print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +print "ok 99\n"; +print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; +print "ok 100\n"; + +print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" + && $w == 3; +print "ok 101\n"; +$w = 0; + +print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; +print "ok 102\n"; +print "not " unless fail(substr($a, -99, 0, "")); +print "ok 103\n"; +print "not " unless fail(substr($a, 99, 3, "")); +print "ok 104\n"; + +substr($a, 0, length($a), "foo"); +print "not " unless $a eq "foo" && !$w; +print "ok 105\n"; + +# using 4 arg substr as lvalue is a compile time error +eval 'substr($a,0,0,"") = "abc"'; +print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; +print "ok 106\n"; diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t new file mode 100755 index 0000000..826cf38 --- /dev/null +++ b/contrib/perl5/t/op/sysio.t @@ -0,0 +1,194 @@ +#!./perl + +print "1..36\n"; + +chdir('op') || die "sysio.t: cannot look for myself: $!"; + +open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; + +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos'); + +$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"; + +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) == 7); +print "ok 29\n"; +# this we should have +print 'not ' unless ($b eq '#!ererl'); +print "ok 30\n"; + +# test sysseek + +print 'not ' unless sysseek(I, 2, 0) == 2; +print "ok 31\n"; +sysread(I, $b, 3); +print 'not ' unless $b eq 'ere'; +print "ok 32\n"; + +print 'not ' unless sysseek(I, -2, 1) == 3; +print "ok 33\n"; +sysread(I, $b, 4); +print 'not ' unless $b eq 'rerl'; +print "ok 34\n"; + +print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; +print "ok 35\n"; +print 'not ' if defined sysseek(I, -1, 1); +print "ok 36\n"; + +close(I); + +unlink $outfile; + +chdir('..'); + +1; + +# eof diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t new file mode 100755 index 0000000..d2cae8e --- /dev/null +++ b/contrib/perl5/t/op/taint.t @@ -0,0 +1,596 @@ +#!./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' if -d '../lib'; +} + +use strict; +use Config; + +# We do not want the whole taint.t to fail +# just because Errno possibly failing. +eval { require Errno; import Errno }; + +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} = ''; + 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..149\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(/tmp /var/tmp /usr/tmp /sys$scratch), + @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 ($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 || ($Is_Dos && $! == 22); # File not found + + 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, "| $foo" } eq '', 'popen to'; + test 77, $@ =~ /^Insecure dependency/, $@; + + test 78, eval { open FOO, "$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 not tainted $getpwent[1] + and not tainted $getpwent[2] + and not tainted $getpwent[3] + and not tainted $getpwent[4] + and not tainted $getpwent[5] + and tainted $getpwent[6] # gecos + and not tainted $getpwent[7] + and not tainted $getpwent[8]); + 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; +} diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t new file mode 100755 index 0000000..77e74db --- /dev/null +++ b/contrib/perl5/t/op/tie.t @@ -0,0 +1,155 @@ +#!./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, 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 warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# strict behaviour, with 1 extra references generating an error +#use warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict error behaviour, with 2 extra references +#use warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 0 ; +use Tie::Hash ; +$A = tie %H, Tie::StdHash; +$C = $B = tied %H ; +{ + #use warning 'untie'; + local $^W = 1 ; + use Tie::Hash ; + tie %h, Tie::StdHash; + untie %h; +} +untie %H; +EXPECT diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t new file mode 100755 index 0000000..8e78b2f --- /dev/null +++ b/contrib/perl5/t/op/tiearray.t @@ -0,0 +1,210 @@ +#!./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 new file mode 100755 index 0000000..e3d2472 --- /dev/null +++ b/contrib/perl5/t/op/tiehandle.t @@ -0,0 +1,137 @@ +#!./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]); + 4; +} + +sub CLOSE { + compare(CLOSE => @_); + + 5; +} + +package main; + +use Symbol; + +print "1..23\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"); + +@expect = (CLOSE => $ob); +$r = close $fh; +ok($r == 5); diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t new file mode 100755 index 0000000..1bec442 --- /dev/null +++ b/contrib/perl5/t/op/time.t @@ -0,0 +1,47 @@ +#!./perl + +# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ + +if ($does_gmtime = gmtime(time)) { print "1..5\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";} diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t new file mode 100755 index 0000000..8ab2ec4 --- /dev/null +++ b/contrib/perl5/t/op/undef.t @@ -0,0 +1,56 @@ +#!./perl + +# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $ + +print "1..21\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"; diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t new file mode 100755 index 0000000..bde78fd --- /dev/null +++ b/contrib/perl5/t/op/universal.t @@ -0,0 +1,104 @@ +#!./perl +# +# check UNIVERSAL +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +print "1..72\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 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->can("drink"); + +test $a->can("eat"); + +test ! $a->can("sleep"); + +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.719 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 diff --git a/contrib/perl5/t/op/unshift.t b/contrib/perl5/t/op/unshift.t new file mode 100755 index 0000000..68d3775 --- /dev/null +++ b/contrib/perl5/t/op/unshift.t @@ -0,0 +1,14 @@ +#!./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/vec.t b/contrib/perl5/t/op/vec.t new file mode 100755 index 0000000..7117144 --- /dev/null +++ b/contrib/perl5/t/op/vec.t @@ -0,0 +1,27 @@ +#!./perl + +# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ + +print "1..15\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 ord($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 ((ord(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"; + diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t new file mode 100755 index 0000000..0a47b6d --- /dev/null +++ b/contrib/perl5/t/op/wantarray.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\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); +1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t new file mode 100755 index 0000000..705fa79 --- /dev/null +++ b/contrib/perl5/t/op/write.t @@ -0,0 +1,169 @@ +#!./perl + +# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ + +print "1..5\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"; + diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t new file mode 100755 index 0000000..0b58bae --- /dev/null +++ b/contrib/perl5/t/pragma/constant.t @@ -0,0 +1,141 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$^W |= 1} # Insist upon 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..39\n"; } +END {print "not ok 1\n" unless $loaded;} +use constant; +$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'; +{ + my $save_warn; + local $^W; + BEGIN { $save_warn = $^W; $^W = 0 } + test 24, TRAILING == 12; + BEGIN { $^W = $save_warn } +} +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, $^W & 1, "Who disabled the warnings?"; diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t new file mode 100755 index 0000000..00baa66 --- /dev/null +++ b/contrib/perl5/t/pragma/locale.t @@ -0,0 +1,483 @@ +#!./perl -wT + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { + print "1..0\n"; + exit; + } +} + +use strict; + +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; + +print "1..", ($have_setlocale ? 102 : 98), "\n"; + +use vars qw($a + $English $German $French $Spanish + @C @English @German @French @Spanish + $Locale @Locale %iLocale %UPPER %lower @Neoalpha); + +$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. + local $^W; # no warnings 'undef' + 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 10, sprintf('%e', 123.456); +check_taint 11, sprintf('%f', 123.456); +check_taint 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; + +sub getalnum { + sort grep /\w/, map { chr } 0..255 +} + +sub locatelocale ($$@) { + my ($lcall, $alnum, @try) = @_; + + undef $$lcall; + + for (@try) { + local $^W = 0; # suppress "Subroutine LC_ALL redefined" + if (setlocale(&LC_ALL, $_)) { + $$lcall = $_; + @$alnum = &getalnum; + last; + } + } + + @$alnum = () unless (defined $$lcall); +} + +# Find some default locale + +locatelocale(\$Locale, \@Locale, qw(C POSIX)); + +# Find some English locale + +locatelocale(\$English, \@English, + qw(en_US.ISO8859-1 en_GB.ISO8859-1 + en en_US en_UK en_IE en_CA en_AU en_NZ + english english.iso88591 + american american.iso88591 + british british.iso88591 + )); + +# Find some German locale + +locatelocale(\$German, \@German, + qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 + de de_DE de_AT de_CH + german german.iso88591)); + +# Find some French locale + +locatelocale(\$French, \@French, + qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 + fr fr_FR fr_BE fr_CA fr_CH + french french.iso88591)); + +# Find some Spanish locale + +locatelocale(\$Spanish, \@Spanish, + qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 + es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 + es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 + es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 + es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 + es es_AR es_BO es_CL + es_CO es_CR es_EC + es_ES es_GT es_MX + es_NI es_PA es_PE + es_PY es_SV es_UY es_VE + spanish spanish.iso88591)); + +# Select the largest of the alpha(num)bets. + +($Locale, @Locale) = ($English, @English) + if (@English > @Locale); +($Locale, @Locale) = ($German, @German) + if (@German > @Locale); +($Locale, @Locale) = ($French, @French) + if (@French > @Locale); +($Locale, @Locale) = ($Spanish, @Spanish) + if (@Spanish > @Locale); + +{ + local $^W = 0; + setlocale(&LC_ALL, $Locale); +} + +# Sort it now that LC_ALL has been set. + +@Locale = sort @Locale; + +print "# Locale = $Locale\n"; +print "# Alnum_ = @Locale\n"; + +{ + my $i = 0; + + for (@Locale) { + $iLocale{$_} = $i++; + } +} + +# Sieve the uppercase and the lowercase. + +for (@Locale) { + if (/[^\d_]/) { # skip digits and the _ + if (lc eq $_) { + $UPPER{$_} = uc; + } else { + $lower{$_} = lc; + } + } +} + +# Find the alphabets that are not alphabets in the default locale. + +{ + no locale; + + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + } +} + +@Neoalpha = sort @Neoalpha; + +# Test \w. + +{ + my $word = join('', @Neoalpha); + + $word =~ /^(\w*)$/; + + print 'not ' if ($1 ne $word); +} +print "ok 99\n"; + +# Find places where the collation order differs from the default locale. + +print "# testing 100\n"; +{ + my (@k, $i, $j, @d); + + { + no locale; + + @k = sort (keys %UPPER, keys %lower); + } + + for ($i = 0; $i < @k; $i++) { + for ($j = $i + 1; $j < @k; $j++) { + if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { + push(@d, [$k[$j], $k[$i]]); + } + } + } + + # Cross-check those places. + + for (@d) { + ($i, $j) = @$_; + if ($i gt $j) { + print "# failed 100 at:\n"; + print "# i = $i, j = $j, i ", + $i le $j ? 'le' : 'gt', " j\n"; + print 'not '; + last; + } + } +} +print "ok 100\n"; + +# Cross-check whole character set. + +print "# testing 101\n"; +for (map { chr } 0..255) { + if (/\w/ and /\W/) { print 'not '; last } + if (/\d/ and /\D/) { print 'not '; last } + if (/\s/ and /\S/) { print 'not '; last } + if (/\w/ and /\D/ and not /_/ and + not (exists $UPPER{$_} or exists $lower{$_})) { + print "# failed 101 at:\n"; + print "# ", ord($_), " '$_'\n"; + print 'not '; + last; + } +} +print "ok 101\n"; + +# Test for read-onlys. + +{ + no locale; + $a = "qwerty"; + { + use locale; + print "not " if $a cmp "qwerty"; + } +} +print "ok 102\n"; + +# This test must be the last one because its failure is not fatal. +# The @Locale should be internally consistent. +# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> +# for inventing a way to test for ordering consistency +# without requiring any particular order. +# ++$jhi;#@iki.fi + +print "# testing 103\n"; +{ + my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Locale)/10); + $to = $from + int(@Locale/10); + $to = $#Locale if ($to > $#Locale); + $lesser = join('', @Locale[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Locale if ($to > $#Locale); + $greater = join('', @Locale[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + @test = + ( + $no.' ($lesser lt $greater)', # 0 + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser gt $greater)', # 5 + $yes.' ($greater lt $lesser )', # 6 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + $no.' ($greater gt $lesser )', # 11 + 'not (($lesser cmp $greater) == -$sign)' # 12 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } + if ($test) { + print "# failed 103 at:\n"; + print "# lesser = '$lesser'\n"; + print "# greater = '$greater'\n"; + print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; + print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; + print "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + printf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + printf("(%s == %4d)", $1, eval $1); + } + print "\n"; + } + + warn "The locale definition on your system may have errors.\n"; + last; + } + } +} + +# eof diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t new file mode 100755 index 0000000..afba8a3 --- /dev/null +++ b/contrib/perl5/t/pragma/overload.t @@ -0,0 +1,698 @@ +#!./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') +} + +# Last test is: +sub last {173} diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs new file mode 100644 index 0000000..7bf1556 --- /dev/null +++ b/contrib/perl5/t/pragma/strict-refs @@ -0,0 +1,295 @@ +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. +######## + +--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. +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 new file mode 100644 index 0000000..61ec286 --- /dev/null +++ b/contrib/perl5/t/pragma/strict-subs @@ -0,0 +1,279 @@ +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 ; +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. diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars new file mode 100644 index 0000000..42107fa --- /dev/null +++ b/contrib/perl5/t/pragma/strict-vars @@ -0,0 +1,223 @@ +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) ; +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. +######## + +# 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. +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. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t new file mode 100755 index 0000000..fc32820 --- /dev/null +++ b/contrib/perl5/t/pragma/strict.t @@ -0,0 +1,93 @@ +#!./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)$/; + + 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_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './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/subs.t b/contrib/perl5/t/pragma/subs.t new file mode 100755 index 0000000..680564f --- /dev/null +++ b/contrib/perl5/t/pragma/subs.t @@ -0,0 +1,133 @@ +#!./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 ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './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 + $results =~ s/Syntax/syntax/; # non-standard yacc + $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 +######## + +--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/warn-1global b/contrib/perl5/t/pragma/warn-1global new file mode 100644 index 0000000..07b5bc8 --- /dev/null +++ b/contrib/perl5/t/pragma/warn-1global @@ -0,0 +1,151 @@ +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. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator 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 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 at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value 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 at - line 3. +######## + +$^W = 1; +eval "my $b ; chop $b ;" ; +EXPECT +Use of uninitialized value at - line 3. +Use of uninitialized value at - line 3. +######## + +eval "$^W = 1;" ; +my $b ; chop $b ; +EXPECT + +######## + +eval {$^W = 1;} ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +{ + 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 at - line 5. +######## +-w +-e undef +EXPECT +Use of uninitialized value at - line 2. diff --git a/contrib/perl5/t/pragma/warning.t b/contrib/perl5/t/pragma/warning.t new file mode 100755 index 0000000..fa0301e --- /dev/null +++ b/contrib/perl5/t/pragma/warning.t @@ -0,0 +1,94 @@ +#!./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/warn-*")) { + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './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 $_ } +} |
