diff options
Diffstat (limited to 'gnu/usr.bin/perl/t')
29 files changed, 1308 insertions, 309 deletions
diff --git a/gnu/usr.bin/perl/t/README b/gnu/usr.bin/perl/t/README index d714295dd25..83843491791 100644 --- a/gnu/usr.bin/perl/t/README +++ b/gnu/usr.bin/perl/t/README @@ -8,4 +8,9 @@ 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 come up with new tests, send them to lwall@sems.com. +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/gnu/usr.bin/perl/t/TEST b/gnu/usr.bin/perl/t/TEST index 291eab5bdb3..cae81031c29 100644 --- a/gnu/usr.bin/perl/t/TEST +++ b/gnu/usr.bin/perl/t/TEST @@ -1,63 +1,76 @@ #!./perl -# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ +# 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] eq '-v') { +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" +die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe'; $ENV{EMXSHELL} = 'sh'; # For OS/2 -if ($ARGV[0] eq '') { +if ($#ARGV == -1) { @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); + `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); } -open(CONFIG,"../config.sh"); -while (<CONFIG>) { - if (/sharpbang='(.*)'/) { - $sharpbang = ($1 eq '#!'); - last; +if ($^O eq 'os2' || $^O eq 'qnx') { + $sharpbang = 0; +} +else { + open(CONFIG, "../config.sh"); + while (<CONFIG>) { + if (/sharpbang='(.*)'/) { + $sharpbang = ($1 eq '#!'); + last; + } } + close(CONFIG); } -$sharpbang = 0 if $ENV{OS2_SHELL}; # OS/2 + $bad = 0; $good = 0; $total = @ARGV; +$files = 0; +$totmax = 0; while ($test = shift) { if ($test =~ /^$/) { next; } $te = $test; chop($te); - print "$te" . '.' x (15 - length($te)); + print "$te" . '.' x (18 - length($te)); if ($sharpbang) { - open(results,"./$test |") || (print "can't run.\n"); + -x $test || (print "isn't executable.\n"); + open(RESULTS,"./$test |") || (print "can't run.\n"); } else { - open(script,"$test") || die "Can't run $test.\n"; - $_ = <script>; - close(script); + open(SCRIPT,"$test") || 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 = ''; } - open(results,"./perl$switch $test |") || (print "can't run.\n"); + open(RESULTS,"./perl$switch $test |") || (print "can't run.\n"); } $ok = 0; $next = 0; - while (<results>) { + while (<RESULTS>) { if ($verbose) { print $_; } @@ -80,11 +93,16 @@ while ($test = shift) { } $next = $next - 1; if ($ok && $next == $max) { - print "ok\n"; - $good = $good + 1; + if ($max) { + print "ok\n"; + $good = $good + 1; + } else { + print "skipping test on this platform\n"; + $files -= 1; + } } else { $next += 1; - print "FAILED on test $next\n"; + print "FAILED at test $next\n"; $bad = $bad + 1; $_ = $test; if (/^base/) { @@ -96,17 +114,31 @@ while ($test = shift) { 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, $pct% okay.\n"; + warn "Failed 1 test script out of $total, $pct% okay.\n"; } else { - die "Failed $bad/$total tests, $pct% okay.\n"; + 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". +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 files=%d tests=%d\n", +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/gnu/usr.bin/perl/t/base/lex.t b/gnu/usr.bin/perl/t/base/lex.t index f25cd2a12c5..6d03b9e8df3 100644 --- a/gnu/usr.bin/perl/t/base/lex.t +++ b/gnu/usr.bin/perl/t/base/lex.t @@ -2,7 +2,7 @@ # $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ -print "1..24\n"; +print "1..27\n"; $x = 'x'; @@ -76,16 +76,32 @@ 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 19\n" : "not ok 19\n"; +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}{$bar}" eq "FOO{BAR}" ? "ok 20\n" : "not ok 20\n"; -print "${foo{$bar}}" eq "BAZ" ? "ok 21\n" : "not ok 21\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"; -print "FOO:" =~ /$foo[:]/ ? "ok 22\n" : "not ok 22\n"; -print "ABC" =~ /^$ary[$A]$/ ? "ok 23\n" : "not ok 23\n"; -print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 24\n" : "not ok 24\n"; +print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 27\n" : "not ok 27\n"); diff --git a/gnu/usr.bin/perl/t/base/term.t b/gnu/usr.bin/perl/t/base/term.t index 42cd56fe0ba..782ad397d33 100644 --- a/gnu/usr.bin/perl/t/base/term.t +++ b/gnu/usr.bin/perl/t/base/term.t @@ -2,12 +2,12 @@ # $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $ -print "1..6\n"; +print "1..7\n"; # check "" interpretation $x = "\n"; -if ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";} +if ($x eq chr(10)) {print "ok 1\n";} else {print "not ok 1\n";} # check `` processing @@ -27,16 +27,19 @@ if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} $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 5\n"; + print "ok 6\n"; } else { - print "not ok 5\n"; + 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 6\n";} else {print "not ok 6\n";} +if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/gnu/usr.bin/perl/t/cmd/mod.t b/gnu/usr.bin/perl/t/cmd/mod.t index 9d9170ff3fa..b4f2731ffa2 100644 --- a/gnu/usr.bin/perl/t/cmd/mod.t +++ b/gnu/usr.bin/perl/t/cmd/mod.t @@ -2,7 +2,7 @@ # $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $ -print "1..7\n"; +print "1..11\n"; print "ok 1\n" if 1; print "not ok 1\n" unless 1; @@ -31,3 +31,17 @@ open(foo,'./TEST') || open(foo,'TEST') || open(foo,'t/TEST'); $x = 0; $x++ while <foo>; print $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n"; + +$x = -0.5; +print "not " if scalar($x) < 0 and $x >= 0; +print "ok 8\n"; + +print "not " unless (-(-$x) < 0) == ($x < 0); +print "ok 9\n"; + +print "ok 10\n" if $x < 0; +print "not ok 10\n" unless $x < 0; + +print "ok 11\n" unless $x > 0; +print "not ok 11\n" if $x > 0; + diff --git a/gnu/usr.bin/perl/t/cmd/while.t b/gnu/usr.bin/perl/t/cmd/while.t index 4c8c10e990a..c6e464d444a 100644 --- a/gnu/usr.bin/perl/t/cmd/while.t +++ b/gnu/usr.bin/perl/t/cmd/while.t @@ -90,6 +90,7 @@ loop: while (<fh>) { 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; diff --git a/gnu/usr.bin/perl/t/comp/cmdopt.t b/gnu/usr.bin/perl/t/comp/cmdopt.t index 4d5c78a4cb5..3f701a456ac 100644 --- a/gnu/usr.bin/perl/t/comp/cmdopt.t +++ b/gnu/usr.bin/perl/t/comp/cmdopt.t @@ -2,7 +2,7 @@ # $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $ -print "1..40\n"; +print "1..44\n"; # test the optimization of constants @@ -81,3 +81,10 @@ 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/gnu/usr.bin/perl/t/comp/cpp.aux b/gnu/usr.bin/perl/t/comp/cpp.aux index fcec0c7abf1..377c74c6c61 100644 --- a/gnu/usr.bin/perl/t/comp/cpp.aux +++ b/gnu/usr.bin/perl/t/comp/cpp.aux @@ -1,6 +1,6 @@ #!./perl -P -# $RCSfile: cpp.aux,v $$Revision: 1.1 $$Date: 1996/08/19 10:13:11 $ +# $RCSfile: cpp.aux,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:02 $ print "1..3\n"; diff --git a/gnu/usr.bin/perl/t/comp/cpp.t b/gnu/usr.bin/perl/t/comp/cpp.t index e62d7b82eec..b9693d060c8 100644 --- a/gnu/usr.bin/perl/t/comp/cpp.t +++ b/gnu/usr.bin/perl/t/comp/cpp.t @@ -1,6 +1,6 @@ #!./perl -# $RCSfile: cpp.t,v $$Revision: 1.1 $$Date: 1996/08/19 10:13:11 $ +# $RCSfile: cpp.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:03 $ BEGIN { chdir 't' if -d 't'; @@ -8,8 +8,9 @@ BEGIN { } use Config; -if ( ($Config{'cppstdin'} =~ /\bcppstdin\b/) and - ( ! -x $Config{'scriptdir'} . "/cppstdin") ) { +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. } diff --git a/gnu/usr.bin/perl/t/comp/multiline.t b/gnu/usr.bin/perl/t/comp/multiline.t index 634b06a7a84..fc1eedc8d25 100644 --- a/gnu/usr.bin/perl/t/comp/multiline.t +++ b/gnu/usr.bin/perl/t/comp/multiline.t @@ -32,9 +32,11 @@ if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";} if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} -$_ = `cat Comp.try`; +$_ = ($^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/gnu/usr.bin/perl/t/comp/package.t b/gnu/usr.bin/perl/t/comp/package.t index ca800bb3647..cef02c5cb4f 100644 --- a/gnu/usr.bin/perl/t/comp/package.t +++ b/gnu/usr.bin/perl/t/comp/package.t @@ -5,7 +5,7 @@ print "1..7\n"; $blurfl = 123; $foo = 3; -package XYZ; +package xyz; $bar = 4; @@ -20,10 +20,10 @@ $ABC'dyick = 6; $xyz = 2; $main = join(':', sort(keys %main::)); -$XYZ = join(':', sort(keys %XYZ::)); +$xyz = join(':', sort(keys %xyz::)); $ABC = join(':', sort(keys %ABC::)); -print $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n"; +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"; diff --git a/gnu/usr.bin/perl/t/comp/script.t b/gnu/usr.bin/perl/t/comp/script.t index a36564a04b2..3731ca078ea 100644 --- a/gnu/usr.bin/perl/t/comp/script.t +++ b/gnu/usr.bin/perl/t/comp/script.t @@ -1,10 +1,11 @@ #!./perl -# $RCSfile: script.t,v $$Revision: 1.1 $$Date: 1996/08/19 10:13:12 $ +# $RCSfile: script.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:08 $ print "1..3\n"; -$x = `./perl -e 'print "ok\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";} @@ -13,12 +14,12 @@ open(try,">Comp.script") || (die "Can't open temp file."); print try 'print "ok\n";'; print try "\n"; close try; -$x = `./perl Comp.script`; +$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`; +$x = `$PERL <Comp.script`; if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; } if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/gnu/usr.bin/perl/t/comp/term.t b/gnu/usr.bin/perl/t/comp/term.t index b248e9b1613..eb9968003e7 100644 --- a/gnu/usr.bin/perl/t/comp/term.t +++ b/gnu/usr.bin/perl/t/comp/term.t @@ -4,7 +4,7 @@ # tests that aren't important enough for base.term -print "1..14\n"; +print "1..22\n"; $x = "\\n"; print "#1\t:$x: eq " . ':\n:' . "\n"; @@ -33,3 +33,38 @@ 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/gnu/usr.bin/perl/t/harness b/gnu/usr.bin/perl/t/harness index c98d91e360e..fe64a046290 100644 --- a/gnu/usr.bin/perl/t/harness +++ b/gnu/usr.bin/perl/t/harness @@ -3,13 +3,17 @@ # We suppose that perl _mostly_ works at this moment, so may use # sophisticated testing. -# Note that _before install_ you may need to run it with -I ../lib flag - +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} 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 = <*/*.t> unless @tests; +@tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests; Test::Harness::runtests @tests; diff --git a/gnu/usr.bin/perl/t/io/argv.t b/gnu/usr.bin/perl/t/io/argv.t index 40ed23b373b..d99865e142e 100644 --- a/gnu/usr.bin/perl/t/io/argv.t +++ b/gnu/usr.bin/perl/t/io/argv.t @@ -8,16 +8,28 @@ open(try, '>Io.argv.tmp') || (die "Can't open temp file."); print try "a line\n"; close try; -$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; - +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";} -$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; - +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";} -$x = `echo foo|./perl -e 'while (<>) {print $_;}'`; - +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'); @@ -33,4 +45,4 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -`/bin/rm -f Io.argv.tmp` if -x '/bin/rm'; +unlink 'Io.argv.tmp'; diff --git a/gnu/usr.bin/perl/t/io/dup.t b/gnu/usr.bin/perl/t/io/dup.t index 901642d8f66..f312671e56b 100644 --- a/gnu/usr.bin/perl/t/io/dup.t +++ b/gnu/usr.bin/perl/t/io/dup.t @@ -17,8 +17,14 @@ select(STDOUT); $| = 1; print STDOUT "ok 2\n"; print STDERR "ok 3\n"; -system 'echo ok 4'; -system 'echo ok 5 1>&2'; +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); @@ -26,7 +32,8 @@ close(STDERR); open(STDOUT,">&dupout"); open(STDERR,">&duperr"); -system 'cat Io.dup'; +if ($^O eq 'MSWin32') { print `type Io.dup` } +else { system 'cat Io.dup' } unlink 'Io.dup'; print STDOUT "ok 6\n"; diff --git a/gnu/usr.bin/perl/t/io/fs.t b/gnu/usr.bin/perl/t/io/fs.t index a219b81eef1..ca82689c6fe 100644 --- a/gnu/usr.bin/perl/t/io/fs.t +++ b/gnu/usr.bin/perl/t/io/fs.t @@ -2,12 +2,23 @@ # $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $ -print "1..22\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +# avoid win32 (for now) +do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; -$wd = `pwd`; +print "1..26\n"; + +$wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; +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'; @@ -26,8 +37,11 @@ if (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 ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";} -if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} +if ($Config{dont_use_nlink} || $nlink == 3) + {print "ok 4\n";} else {print "not ok 4\n";} + +if (($mode & 0777) == 0666 || $^O eq 'amigaos') + {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";} @@ -61,7 +75,8 @@ if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} -if (($atime == 500000000 && $mtime == 500000001) || $wd =~ m#/afs/#) +if (($atime == 500000000 && $mtime == 500000001) + || $wd =~ m#/afs/# || $^O eq 'amigaos') {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";} @@ -73,13 +88,41 @@ 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 (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links +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 (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} + truncate FH, 0; + if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} + close FH; +} +unlink "Iofs.tmp"; diff --git a/gnu/usr.bin/perl/t/io/inplace.t b/gnu/usr.bin/perl/t/io/inplace.t index 477add19423..2652c8bebef 100644 --- a/gnu/usr.bin/perl/t/io/inplace.t +++ b/gnu/usr.bin/perl/t/io/inplace.t @@ -7,7 +7,16 @@ $^I = '.bak'; print "1..2\n"; @ARGV = ('.a','.b','.c'); -`echo foo | tee .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`; +} +else { + $CAT = 'cat'; + `echo foo | tee .a .b .c`; +} while (<>) { s/foo/bar/; } @@ -15,7 +24,7 @@ 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.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} +if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";} +if (`$CAT .a.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} unlink '.a', '.b', '.c', '.a.bak', '.b.bak', '.c.bak'; diff --git a/gnu/usr.bin/perl/t/io/pipe.t b/gnu/usr.bin/perl/t/io/pipe.t index 95df4dccb65..ac149810ec9 100644 --- a/gnu/usr.bin/perl/t/io/pipe.t +++ b/gnu/usr.bin/perl/t/io/pipe.t @@ -2,8 +2,18 @@ # $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..8\n"; +print "1..10\n"; open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); print PIPE "Xk 1\n"; @@ -54,3 +64,47 @@ print WRITER "not ok 7\n"; close WRITER; print "ok 8\n"; + +# VMS doesn't like spawning subprocesses that are still connected to +# STDOUT. Someone should modify tests #9 and #10 to work with VMS. + +if ($^O eq 'VMS') { + print "ok 9\n"; + print "ok 10\n"; + exit; +} + +if ($Config{d_sfio} || $^O eq machten) { + # 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. + 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"; +} diff --git a/gnu/usr.bin/perl/t/io/tell.t b/gnu/usr.bin/perl/t/io/tell.t index 5badafeacba..83904e88bba 100644 --- a/gnu/usr.bin/perl/t/io/tell.t +++ b/gnu/usr.bin/perl/t/io/tell.t @@ -7,7 +7,7 @@ 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>; diff --git a/gnu/usr.bin/perl/t/lib/anydbm.t b/gnu/usr.bin/perl/t/lib/anydbm.t index 7dbf3760b81..a83da81e1c6 100644 --- a/gnu/usr.bin/perl/t/lib/anydbm.t +++ b/gnu/usr.bin/perl/t/lib/anydbm.t @@ -1,6 +1,6 @@ #!./perl -# $RCSfile: anydbm.t,v $$Revision: 1.1 $$Date: 1996/08/19 10:13:13 $ +# $RCSfile: anydbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:20 $ BEGIN { chdir 't' if -d 't'; @@ -15,15 +15,21 @@ 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"); +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*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -80,7 +86,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -111,4 +117,5 @@ 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; diff --git a/gnu/usr.bin/perl/t/lib/bigintpm.t b/gnu/usr.bin/perl/t/lib/bigintpm.t index b229d7c67ba..ebaecac21af 100644 --- a/gnu/usr.bin/perl/t/lib/bigintpm.t +++ b/gnu/usr.bin/perl/t/lib/bigintpm.t @@ -1,8 +1,11 @@ #!./perl -BEGIN { unshift @INC, './lib', '../lib'; - require Config; import Config; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; } + +use Config; use Math::BigInt; $test = 0; diff --git a/gnu/usr.bin/perl/t/lib/db-btree.t b/gnu/usr.bin/perl/t/lib/db-btree.t index d90de6cd590..bebb63df8d0 100644 --- a/gnu/usr.bin/perl/t/lib/db-btree.t +++ b/gnu/usr.bin/perl/t/lib/db-btree.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -12,73 +12,99 @@ BEGIN { use DB_File; use Fcntl; -print "1..76\n"; +print "1..102\n"; -$Dfile = "Op.db-btree"; +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 -$dbh = TIEHASH DB_File::BTREEINFO ; -print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ; -print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ; -print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ; +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 ; -print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{flags} == 3000) ; $dbh->{cachesize} = 9000 ; -print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ; -# +ok(10, $dbh->{cachesize} == 9000); + $dbh->{psize} = 400 ; -print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{psize} == 400) ; $dbh->{lorder} = 65 ; -print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 65) ; $dbh->{minkeypage} = 123 ; -print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ; +ok(13, $dbh->{minkeypage} == 123) ; $dbh->{maxkeypage} = 1234 ; -print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ; +ok(14, $dbh->{maxkeypage} == 1234 ); $dbh->{compare} = 1234 ; -print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ; +ok(15, $dbh->{compare} == 1234) ; $dbh->{prefix} = 1234 ; -print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ; +ok(16, $dbh->{prefix} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ; +ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ; +ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE -print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19"); +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); -print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n"); +ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; } -print (!$i ? "ok 21\n" : "not ok 21\n"); +ok(21, !$i ) ; $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; -print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ; -print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n"); +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"; @@ -110,7 +136,7 @@ untie(%h); # tie to the same file again -print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n"); +ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; # Modify an entry from the previous tie $h{'g'} = 'G'; @@ -141,48 +167,45 @@ $X->DELETE('goner3'); @keys = keys(%h); @values = values(%h); -if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";} +ok(27, $#keys == 29 && $#values == 29) ; +$i = 0 ; while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + 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 26\n";} else {print "not ok 26\n";} +ok(28, $i == 30) ; -@keys = ('blurfl', keys(h), 'dyick'); -if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";} +@keys = ('blurfl', keys(%h), 'dyick'); +ok(29, $#keys == 31) ; #Check that the keys can be retrieved in order -$ok = 1 ; -foreach (keys %h) -{ - ($ok = 0), last if defined $previous && $previous gt $_ ; - $previous = $_ ; -} -print ($ok ? "ok 28\n" : "not ok 28\n") ; +my @b = keys %h ; +my @c = sort lexical @b ; +ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; -print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ; +ok(31, $h{'foo'} eq '' ) ; $h{''} = 'bar'; -print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ; +ok(32, $h{''} eq '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 31\n" : "not ok 31\n"); +ok(33, $ok); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 32\n" : "not ok 32\n"); +ok(34, $size > 0 ); @h{0..200} = 200..400; @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n"; +ok(35, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -191,52 +214,53 @@ print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n"; # an existing record. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -print ($status == 1 ? "ok 34\n" : "not ok 34\n") ; +ok(36, $status == 1 ); # check that the value of the key 'x' has not been changed by the # previous test -print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ; +ok(37, $h{'x'} eq 'X' ); # standard put $status = $X->put('key', 'value') ; -print ($status == 0 ? "ok 36\n" : "not ok 36\n") ; +ok(38, $status == 0 ); #check that previous put can be retrieved +$value = 0 ; $status = $X->get('key', $value) ; -print ($status == 0 ? "ok 37\n" : "not ok 37\n") ; -print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ; +ok(39, $status == 0 ); +ok(40, $value eq 'value' ); # Attempting to delete an existing key should work $status = $X->del('q') ; -print ($status == 0 ? "ok 39\n" : "not ok 39\n") ; +ok(41, $status == 0 ); $status = $X->del('') ; -print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; +ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ; -print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ; +ok(43, ! defined $h{'q'}) ; +ok(44, ! defined $h{''}) ; undef $X ; untie %h ; -print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43"); +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') ; -print ($status == 1 ? "ok 44\n" : "not ok 44\n") ; +ok(46, $status == 1 ); # Check the get interface # First a non-existing key $status = $X->get('aaaa', $value) ; -print ($status == 1 ? "ok 45\n" : "not ok 45\n") ; +ok(47, $status == 1 ); # Next an existing key $status = $X->get('a', $value) ; -print ($status == 0 ? "ok 46\n" : "not ok 46\n") ; -print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ; +ok(48, $status == 0 ); +ok(49, $value eq 'A' ); # seq # ### @@ -245,15 +269,15 @@ print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ; $key = 'ke' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 48\n" : "not ok 48\n") ; -print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ; -print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ; +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) ; -print ($status == 1 ? "ok 51\n" : "not ok 51\n") ; +ok(53, $status == 1 ); # use seq to set the cursor, then delete the record @ the cursor. @@ -261,35 +285,35 @@ print ($status == 1 ? "ok 51\n" : "not ok 51\n") ; $key = 'x' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 52\n" : "not ok 52\n") ; -print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ; -print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ; +ok(54, $status == 0 ); +ok(55, $key eq 'x' ); +ok(56, $value eq 'X' ); $status = $X->del(0, R_CURSOR) ; -print ($status == 0 ? "ok 55\n" : "not ok 55\n") ; +ok(57, $status == 0 ); $status = $X->get('x', $value) ; -print ($status == 1 ? "ok 56\n" : "not ok 56\n") ; +ok(58, $status == 1 ); # ditto, but use put to replace the key/value pair. $key = 'y' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 57\n" : "not ok 57\n") ; -print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ; -print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ; +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) ; -print ($status == 0 ? "ok 60\n" : "not ok 60\n") ; -print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ; -print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ; +ok(62, $status == 0 ); +ok(63, $key eq 'replace key' ); +ok(64, $value eq 'replace value' ); $status = $X->get('y', $value) ; -print ($status == 1 ? "ok 63\n" : "not ok 63\n") ; +ok(65, $status == 1 ); # use seq to walk forwards through a file $status = $X->seq($key, $value, R_FIRST) ; -print ($status == 0 ? "ok 64\n" : "not ok 64\n") ; +ok(66, $status == 0 ); $previous = $key ; $ok = 1 ; @@ -298,12 +322,12 @@ while (($status = $X->seq($key, $value, R_NEXT)) == 0) ($ok = 0), last if ($previous cmp $key) == 1 ; } -print ($status == 1 ? "ok 65\n" : "not ok 65\n") ; -print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ; +ok(67, $status == 1 ); +ok(68, $ok == 1 ); # use seq to walk backwards through a file $status = $X->seq($key, $value, R_LAST) ; -print ($status == 0 ? "ok 67\n" : "not ok 67\n") ; +ok(69, $status == 0 ); $previous = $key ; $ok = 1 ; @@ -313,8 +337,8 @@ while (($status = $X->seq($key, $value, R_PREV)) == 0) #print "key = [$key] value = [$value]\n" ; } -print ($status == 1 ? "ok 68\n" : "not ok 68\n") ; -print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ; +ok(70, $status == 1 ); +ok(71, $ok == 1 ); # check seq FIRST/LAST @@ -323,14 +347,14 @@ print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ; # #### $status = $X->sync ; -print ($status == 0 ? "ok 70\n" : "not ok 70\n") ; +ok(72, $status == 0 ); # fd # ## $status = $X->fd ; -print ($status != 0 ? "ok 71\n" : "not ok 71\n") ; +ok(73, $status != 0 ); undef $X ; @@ -339,41 +363,92 @@ untie %h ; unlink $Dfile; # Now try an in memory file -print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72"); +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 ; -print ($status == -1 ? "ok 73\n" : "not ok 73\n") ; +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 = TIEHASH DB_File::BTREEINFO ; -$dbh1->{compare} = sub { $_[0] <=> $_[1] } ; +$dbh1 = new DB_File::BTREEINFO ; +{ local $^W = 0 ; + $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } -$dbh2 = TIEHASH DB_File::BTREEINFO ; +$dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = TIEHASH DB_File::BTREEINFO ; +$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 ) ; +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 ) ; -@srt_1 = sort { $a <=> $b } @Keys ; +{ 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) { - $h{$_} = 1 ; + { local $^W = 0 ; + $h{$_} = 1 ; } $g{$_} = 1 ; $k{$_} = 1 ; } @@ -392,13 +467,142 @@ sub ArrayCompare 1 ; } -print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ; -print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ; -print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ; +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]]") ; + + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + exit ; diff --git a/gnu/usr.bin/perl/t/lib/db-hash.t b/gnu/usr.bin/perl/t/lib/db-hash.t index 6c3ef552001..9df918cce5a 100644 --- a/gnu/usr.bin/perl/t/lib/db-hash.t +++ b/gnu/usr.bin/perl/t/lib/db-hash.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -12,65 +12,78 @@ BEGIN { use DB_File; use Fcntl; -print "1..43\n"; +print "1..62\n"; -$Dfile = "Op.db-hash"; +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 -$dbh = TIEHASH DB_File::HASHINFO ; -print (($dbh->{bsize} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{ffactor} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{nelem} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{cachesize} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{hash} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{lorder} == undef) ? "ok 6\n" : "not ok 6\n") ; +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 ; -print ($dbh->{bsize} == 3000 ? "ok 7\n" : "not ok 7\n") ; +ok(7, $dbh->{bsize} == 3000 ); $dbh->{ffactor} = 9000 ; -print ($dbh->{ffactor} == 9000 ? "ok 8\n" : "not ok 8\n") ; -# +ok(8, $dbh->{ffactor} == 9000 ); + $dbh->{nelem} = 400 ; -print (($dbh->{nelem} == 400) ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{nelem} == 400 ); $dbh->{cachesize} = 65 ; -print (($dbh->{cachesize} == 65) ? "ok 10\n" : "not ok 10\n") ; +ok(10, $dbh->{cachesize} == 65 ); $dbh->{hash} = "abc" ; -print (($dbh->{hash} eq "abc") ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{hash} eq "abc" ); $dbh->{lorder} = 1234 ; -print ($dbh->{lorder} == 1234 ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 13\n" : "not ok 13\n") ; -eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 14\n" : "not ok 14\n") ; +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 -print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 15\n" : "not ok 15"); +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); -print (($mode & 0777) == 0640 ? "ok 16\n" : "not ok 16\n"); +ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; } -print (!$i ? "ok 17\n" : "not ok 17\n"); +ok(17, !$i ); $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; -print ($h{'abc'} == 'ABC' ? "ok 18\n" : "not ok 18\n") ; -print (defined $h{'jimmy'} ? "not ok 19\n" : "ok 19\n"); +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"; @@ -102,7 +115,7 @@ untie(%h); # tie to the same file again, do not supply a type - should default to HASH -print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640)) ? "ok 20\n" : "not ok 20: $!\n"); +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); # Modify an entry from the previous tie $h{'g'} = 'G'; @@ -133,39 +146,40 @@ $X->DELETE('goner3'); @keys = keys(%h); @values = values(%h); -if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";} +ok(23, $#keys == 29 && $#values == 29) ; -while (($key,$value) = each(h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { +$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; } } -if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";} +ok(24, $i == 30) ; -@keys = ('blurfl', keys(h), 'dyick'); -if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";} +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; $h{'foo'} = ''; -print ($h{'foo'} eq '' ? "ok 24\n" : "not ok 24\n") ; +ok(26, $h{'foo'} eq '' ); $h{''} = 'bar'; -print ($h{''} eq 'bar' ? "ok 25\n" : "not ok 25\n") ; +ok(27, $h{''} eq '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 26\n" : "not ok 26\n"); +ok(28, $ok ); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 27\n" : "not ok 27\n"); +ok(29, $size > 0 ); @h{0..200} = 200..400; @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n"; +ok(30, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -174,44 +188,47 @@ print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n"; # an existing record. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -print ($status == 1 ? "ok 29\n" : "not ok 29\n") ; +ok(31, $status == 1 ); # check that the value of the key 'x' has not been changed by the # previous test -print ($h{'x'} eq 'X' ? "ok 30\n" : "not ok 30\n") ; +ok(32, $h{'x'} eq 'X' ); # standard put $status = $X->put('key', 'value') ; -print ($status == 0 ? "ok 31\n" : "not ok 31\n") ; +ok(33, $status == 0 ); #check that previous put can be retrieved +$value = 0 ; $status = $X->get('key', $value) ; -print ($status == 0 ? "ok 32\n" : "not ok 32\n") ; -print ($value eq 'value' ? "ok 33\n" : "not ok 33\n") ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); # Attempting to delete an existing key should work $status = $X->del('q') ; -print ($status == 0 ? "ok 34\n" : "not ok 34\n") ; +ok(36, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -print (($h{'q'} eq undef) ? "ok 35\n" : "not ok 35\n") ; +$^W = 0 ; +ok(37, $h{'q'} eq undef ); +$^W = 1 ; # Attempting to delete a non-existant key should fail $status = $X->del('joe') ; -print ($status == 1 ? "ok 36\n" : "not ok 36\n") ; +ok(38, $status == 1 ); # Check the get interface # First a non-existing key $status = $X->get('aaaa', $value) ; -print ($status == 1 ? "ok 37\n" : "not ok 37\n") ; +ok(39, $status == 1 ); # Next an existing key $status = $X->get('a', $value) ; -print ($status == 0 ? "ok 38\n" : "not ok 38\n") ; -print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); # seq # ### @@ -226,28 +243,172 @@ print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ; # #### $status = $X->sync ; -print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; +ok(42, $status == 0 ); # fd # ## $status = $X->fd ; -print ($status != 0 ? "ok 41\n" : "not ok 41\n") ; +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 -print (($X = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 42\n" : "not ok 42"); +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 ; -print ($status == -1 ? "ok 43\n" : "not ok 43\n") ; +ok(48, $status == -1 ); -untie %h ; 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]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + +} exit ; diff --git a/gnu/usr.bin/perl/t/lib/db-recno.t b/gnu/usr.bin/perl/t/lib/db-recno.t index 64ad7b8a9ef..9950741ffea 100644 --- a/gnu/usr.bin/perl/t/lib/db-recno.t +++ b/gnu/usr.bin/perl/t/lib/db-recno.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -11,126 +11,185 @@ BEGIN { use DB_File; use Fcntl; +use strict ; +use vars qw($dbh $Dfile $bad_ones) ; -print "1..30\n"; +sub ok +{ + my $no = shift ; + my $result = shift ; -$Dfile = "Op.db-recno"; -unlink $Dfile; + 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..66\n"; + +my $Dfile = "recno.tmp"; +unlink $Dfile ; umask(0); # Check the interface to RECNOINFO -$dbh = TIEHASH DB_File::RECNOINFO ; -print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ; -print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ; +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 ; -print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ; +ok(8, $dbh->{bval} == 3000 ); $dbh->{cachesize} = 9000 ; -print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{cachesize} == 9000 ); $dbh->{psize} = 400 ; -print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ; +ok(10, $dbh->{psize} == 400 ); $dbh->{flags} = 65 ; -print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{flags} == 65 ); $dbh->{lorder} = 123 ; -print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 123 ); $dbh->{reclen} = 1234 ; -print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ; +ok(13, $dbh->{reclen} == 1234 ); $dbh->{bfname} = 1234 ; -print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ; +ok(14, $dbh->{bfname} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ; -eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ; +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 -print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17"); +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n"); +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) + || $^O eq 'amigaos') ; -#$l = @h ; -$l = $X->length ; -print (!$l ? "ok 19\n" : "not ok 19\n"); +#my $l = @h ; +my $l = $X->length ; +ok(19, !$l ); -@data = qw( a b c d ever f g h i j k longername m n o p) ; +my @data = qw( a b c d ever f g h i j k longername m n o p) ; $h[0] = shift @data ; -print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ; +ok(20, $h[0] eq 'a' ); +my $ i; foreach (@data) { $h[++$i] = $_ } unshift (@data, 'a') ; -print (defined $h[1] ? "ok 21\n" : "not ok 21\n"); -print (! defined $h[16] ? "ok 22\n" : "not ok 22\n"); -print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ; +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $X->length == @data ); # Overwrite an entry & check fetch it $h[3] = 'replaced' ; $data[3] = 'replaced' ; -print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n"); +ok(24, $h[3] eq 'replaced' ); #PUSH -@push_data = qw(added to the end) ; -#push (@h, @push_data) ; +my @push_data = qw(added to the end) ; +#my push (@h, @push_data) ; $X->push(@push_data) ; push (@data, @push_data) ; -print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n"); +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 -pop (@data) ; -#$value = pop(@h) ; -$value = $X->pop ; -print ($value eq 'end' ? "not ok 26\n" : "ok 26\n"); +my $popped = pop (@data) ; +#my $value = pop(@h) ; +my $value = $X->pop ; +ok(29, $value eq $popped) ; # SHIFT #$value = shift @h $value = $X->shift ; -print ($value eq shift @data ? "not ok 27\n" : "ok 27\n"); +my $shifted = shift @data ; +ok(30, $value eq $shifted ); # UNSHIFT # empty list $X->unshift ; -print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ; +ok(31, $X->length == @data ); -@new_data = qw(add this to the start of the array) ; +my @new_data = qw(add this to the start of the array) ; #unshift @h, @new_data ; $X->unshift (@new_data) ; unshift (@data, @new_data) ; -print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ; +ok(32, $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 -$ok = 1 ; -$j = 0 ; +my $ok = 1 ; +my $j = 0 ; foreach (@data) { $ok = 0, last if $_ ne $h[$j ++] ; } -print ($ok ? "ok 30\n" : "not ok 30\n") ; +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[$X->length -1] ); + +# get the first element using a negative subscript +eval '$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 + $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. @@ -139,4 +198,188 @@ 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]]") ; + + unlink "SubDB.pm", "recno.tmp" ; + +} + exit ; diff --git a/gnu/usr.bin/perl/t/lib/dirhand.t b/gnu/usr.bin/perl/t/lib/dirhand.t index 8403609578e..aa7be356df3 100644 --- a/gnu/usr.bin/perl/t/lib/dirhand.t +++ b/gnu/usr.bin/perl/t/lib/dirhand.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bPOSIX\b/) { + if (not $Config{'d_readdir'}) { print "1..0\n"; exit 0; } @@ -17,7 +17,7 @@ print "1..5\n"; $dot = new DirHandle "."; print defined($dot) ? "ok" : "not ok", " 1\n"; -@a = <*>; +@a = sort <*>; do { $first = $dot->read } while defined($first) && $first =~ /^\./; print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; diff --git a/gnu/usr.bin/perl/t/lib/filehand.t b/gnu/usr.bin/perl/t/lib/filehand.t index fc433502126..cedc2ebcb82 100644 --- a/gnu/usr.bin/perl/t/lib/filehand.t +++ b/gnu/usr.bin/perl/t/lib/filehand.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bFileHandle\b/ && $^O ne 'VMS') { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; exit 0; } @@ -13,23 +13,72 @@ BEGIN { use FileHandle; use strict subs; +autoflush STDOUT 1; + $mystdout = new_from_fd FileHandle 1,"w"; -autoflush STDOUT; +$| = 1; autoflush $mystdout; -print "1..4\n"; +print "1..11\n"; print $mystdout "ok ",fileno($mystdout),"\n"; -$fh = new FileHandle "TEST", O_RDONLY and print "ok 2\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"; -if ($^O eq 'VMS') { - ungetc $fh 65; - CORE::read($fh, $buf,1); + +ungetc $fh 65; +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"; + +($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 { - ungetc STDIN 65; - CORE::read(STDIN, $buf,1); + if (fork) { + $wr->close; + print $rd->getline; + } + else { + $rd->close; + $wr->printf("ok %d\n",11); + exit(0); + } } -print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; diff --git a/gnu/usr.bin/perl/t/lib/gdbm.t b/gnu/usr.bin/perl/t/lib/gdbm.t index 92e4eb219de..53b0351ed3a 100644 --- a/gnu/usr.bin/perl/t/lib/gdbm.t +++ b/gnu/usr.bin/perl/t/lib/gdbm.t @@ -1,6 +1,6 @@ #!./perl -# $RCSfile: gdbm.t,v $$Revision: 1.1 $$Date: 1996/08/19 10:13:15 $ +# $RCSfile: gdbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:31 $ BEGIN { @INC = '../lib'; @@ -13,7 +13,7 @@ BEGIN { use GDBM_File; -print "1..12\n"; +print "1..20\n"; unlink <Op.dbmx*>; @@ -24,9 +24,14 @@ $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -83,7 +88,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -114,4 +119,88 @@ 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]]") ; + + unlink "SubDB.pm", <dbhash.tmp*> ; + +} diff --git a/gnu/usr.bin/perl/t/re_tests b/gnu/usr.bin/perl/t/re_tests deleted file mode 100644 index 2ac666ab382..00000000000 --- a/gnu/usr.bin/perl/t/re_tests +++ /dev/null @@ -1,3 +0,0 @@ -a.+?c abcabc y $& abc -(a+|b)* ab y $&-$1 ab-b -(a+|b){0,} ab y $&-$1 ab-b |